VBA如何匹配多个预设工作表名实现多Excel文件数据批量汇总

核心错误原因 #

• RefFirstExistingWorksheet函数的Delimiter（分隔符）参数默认值设置错误：分隔符的作用是将传入的工作表名列表切分为单独的工作表名称，此处应该为半角逗号,，但你的代码中将默认值误写为"Parts,Function Manifold"，导致Split函数无法正确拆分预设工作表名，因此永远匹配不到存在的工作表。
• 调用函数时未显式传入分隔符参数，默认使用了错误的分隔符，进一步导致匹配失效。
• 隐性错误：代码中粘贴值的语句未显式指定所属工作表，默认指向活动工作表，可能出现粘贴位置错误、数据写错工作表的问题。

修正后的完整代码 #

Sub CopyFilesContent()
    
    Const ProcTitle As String = "Copy Files Contents"
    Const wsNamesList As String = "Parts,Function Manifold,Manifolding,Whatever"
    Const DELIMITER As String = "," '统一管理分隔符
    
    Dim oFSO As Object, oFolder As Object, oFile As Object, wb As Workbook, ws As Worksheet
    Dim i As Long, j As Long, LR As Long, lastR As Long, firstR As Long, wsFN As Worksheet

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder("C:\Users\user name\Downloads\Test Consolidate Folder\2021")
    Set wsFN = Workbooks("Consolidate.xlsm").Worksheets("Master")
    
    For Each oFile In oFolder.Files
        Set wb = Workbooks.Open(oFile)    'open the workbook to copy from
        ' 显式传入分隔符参数
        Set ws = RefFirstExistingWorksheet(wb, wsNamesList, DELIMITER)
        If Not ws Is Nothing Then
        
            LR = wsFN.Cells(wsFN.Rows.Count, 1).End(xlUp).Row + 1       'last empty row in the master FileName sheet
            wsFN.Cells(LR, 1) = oFile.Name                            'write the wb to copy from name
            lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row - 2 'last row in the sheet where to copy from
        
            ' 所有单元格操作都显式指定所属工作表
            ws.Cells(4, 13).FormulaR1C1 = "=MATCH(1,C[-12],0)"
            ws.Cells(4, 13).Copy
            ws.Cells(4, 13).PasteSpecial Paste:=xlPasteValues
        
            firstR = ws.Cells(4, 13).Value
        
            ws.Cells(3, 13).Copy
            ws.Range("K" & firstR & ":K" & lastR).PasteSpecial Paste:=xlPasteValues
            ws.Range("A10:N" & lastR).Copy wsFN.Range("A" & LR + 1) 'copy the necessary range

            wb.Close False  'close the workbook, without saving it
        Else
            MsgBox "目标工作表未找到，文件：'" & oFile.Name & "'。", _
                vbCritical, ProcTitle
            wb.Close False '匹配不到工作表时也要关闭打开的文件，避免文件残留
        End If
    Next oFile
   
    ' 操作主表也显式指定对象，避免指向错误工作表
    wsFN.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    ' 清理对象
    Set wsFN = Nothing
    Set oFolder = Nothing
    Set oFSO = Nothing
    MsgBox "汇总完成！", vbInformation, ProcTitle
End Sub

Function RefFirstExistingWorksheet( _
    ByVal wb As Workbook, _
    ByVal WorksheetNamesList As String, _
    Optional ByVal Delimiter As String = ",") _
As Worksheet
    If wb Is Nothing Then Exit Function
    If Len(WorksheetNamesList) = 0 Then Exit Function
    Dim wsNames() As String: wsNames = Split(WorksheetNamesList, Delimiter)
    Dim wsName As Variant
    For Each wsName In wsNames
        ' 去除工作表名前后多余空格，避免因名称前后带空格导致匹配失败
        wsName = Trim(wsName)
        On Error Resume Next
        Set RefFirstExistingWorksheet = wb.Worksheets(wsName)
        On Error GoTo 0
        If Not RefFirstExistingWorksheet Is Nothing Then
            Exit For
        End If
    Next wsName
End Function

额外优化说明 #

• 修正了匹配不到工作表时文件未关闭的问题，避免出现后台残留Excel进程的情况
• 所有单元格/区域操作都显式指定了所属工作表，避免活动工作表切换导致的逻辑错误
• 增加了工作表名Trim逻辑，避免因名称前后存在不可见空格导致匹配失败
• 统一管理分隔符，后续修改分隔符不需要多处调整

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