如何在不打开目标工作簿的情况下调用Sub过程拆分大Excel文件

核心问题 #

你的宏在空白工作簿中运行无结果，根源在于：

• split_excel 子程序用 ThisWorkbook 指向了存放宏的空白工作簿，而非通过 CreateObject 打开的目标大文件。
• 调用 split_excel 时未传递目标文件的引用，导致子程序完全没访问到需要拆分的数据源。

修复后的完整代码 #

Option Explicit

Function IsFileOpen(FileName As String)
    Dim iFilenum As Long
    Dim iErr As Long
    On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error GoTo 0
    Select Case iErr
        Case 0: IsFileOpen = False
        Case 70: IsFileOpen = True
        Case Else: Error iErr
    End Select
End Function

Sub ModificarArchivo()
    Dim data_sh As Worksheet
    Set data_sh = ThisWorkbook.Sheets(1)
    Dim ajustes_sh As Worksheet
    Set ajustes_sh = ThisWorkbook.Sheets(2)
    
    Dim Archive As Application
    Dim Archivename As String
    Dim targetWB As Workbook
    
    Set Archive = CreateObject("Excel.Application")
    Archive.Visible = False ' 后台运行，避免弹窗干扰
    
    Archivename = data_sh.Range("E14").Value
    
    If Not IsFileOpen(Archivename) Then
        Set targetWB = Archive.Workbooks.Open(Archivename)
        ' 传递目标文件和设置表给拆分子程序
        split_excel targetWB, ajustes_sh
        targetWB.Close False ' 关闭目标文件，不保存更改
    End If
    
    Archive.Quit
    Set Archive = Nothing ' 释放后台Excel实例资源
End Sub

Sub split_excel(targetWB As Workbook, settingsWS As Worksheet)
    Dim datos_sh As Worksheet
    Set datos_sh = targetWB.Sheets(1) ' 指向目标文件的第一个数据工作表
    Dim saveDir As String
    saveDir = settingsWS.Range("H6").Value
    
    ' 确保保存目录存在，避免保存失败
    If Dir(saveDir, vbDirectory) = "" Then
        MkDir saveDir
    End If
    
    targetWB.Application.ScreenUpdating = False ' 关闭后台实例的屏幕刷新，提升运行速度
    
    ' 清理设置表的临时数据
    settingsWS.Range("A:A").Clear
    
    ' 复制目标文件B列到设置表，提取唯一值
    datos_sh.AutoFilterMode = False
    datos_sh.Range("B2:B" & datos_sh.Cells(datos_sh.Rows.Count, "B").End(xlUp).Row).Copy settingsWS.Range("A1")
    settingsWS.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes ' 修正原代码去重列错误
    
    Dim i As Integer
    For i = 2 To Application.CountA(settingsWS.Range("A:A"))
        Dim filterValue As String
        filterValue = settingsWS.Range("A" & i).Value
        
        ' 按B列筛选目标数据
        datos_sh.UsedRange.AutoFilter Field:=2, Criteria1:=filterValue
        
        ' 创建新工作簿并复制筛选后的数据
        Dim nwb As Workbook
        Set nwb = targetWB.Application.Workbooks.Add ' 使用后台实例创建新文件
        Dim nsh As Worksheet
        Set nsh = nwb.Sheets(1)
        
        datos_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
        nsh.UsedRange.EntireColumn.ColumnWidth = 15
        nsh.UsedRange.Rows(1).EntireRow.Delete ' 删除重复表头（可根据需求调整）
        
        ' 保存拆分后的文件
        nwb.SaveAs saveDir & "\" & filterValue & ".xlsx"
        nwb.Close False
        
        datos_sh.AutoFilterMode = False ' 清除筛选
    Next i
    
    ' 清理临时数据并恢复设置
    settingsWS.Range("A:A").Clear
    targetWB.Application.ScreenUpdating = True
    MsgBox "Done"
End Sub

关键修改点 #

1. 传递目标工作簿引用：将 split_excel 修改为接收目标文件和设置表参数，确保操作的是正确数据源。
2. 修正数据源指向：替换所有 ThisWorkbook 为传入的目标工作簿，避免操作宏所在的空白工作簿。
3. 添加目录检查：自动创建不存在的保存目录，避免保存失败。
4. 修复去重逻辑：原代码 RemoveDuplicates Columns:=Array(1,2) 有误，改为仅按第一列去重。
5. 资源释放：添加 Set Archive = Nothing 释放后台实例，避免内存泄漏。

使用说明 #

• 确保宏所在工作簿的Sheet1的E14单元格填写目标大文件的完整路径，Sheet2的H6单元格填写拆分后文件的保存路径。
• 运行 ModificarArchivo 子程序即可在后台处理目标文件，无需手动打开它。

内容的提问来源于stack exchange，提问作者Rafael Suazo