根据文件名将excel文件合并到一个新的excel文件中

Question

我有一个文件夹，其中包含我制作的脚本中的大约 500-600 个 excel 文件，其中文件名最终是这样的

101a12345.xlsx
101a67899.xlsx
102a12345.xlsx
102a78999.xlsx

文件名遵循该模式、101a、102a 等。我想要做的是将基于该模式的文件合并到 1 个 excel 文件中。因此，101a12345.xlsx 和 101a67899.xlsx 应合并为 101aMaster.xlsx。所有的excel文件都是单张的。

我在这里找到了我正在尝试实现的示例代码：How to merge multiple workbooks into one based on workbooks names

取自以上链接：

Sub test(sourceFolder As String, destinationFolder As String)
    Const TO_DELETE_SHEET_NAME As String = "toBeDeleted"
    '------------------------------------------------------------------
    Dim settingSheetsNumber As Integer
    Dim settingDisplayAlerts As Boolean
    Dim dict As Object
    Dim wkbSource As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim filepath As String
    Dim code As String * 4
    Dim wkbDestination As Excel.Workbook
    Dim varKey As Variant
    '------------------------------------------------------------------


    'Change [SheetsInNewWorkbook] setting of Excel.Application object to
    'create new workbooks with a single sheet only.
    With Excel.Application
        settingDisplayAlerts = .DisplayAlerts
        settingSheetsNumber = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
        .DisplayAlerts = False
    End With


    Set dict = VBA.CreateObject("Scripting.Dictionary")


    filepath = Dir(sourceFolder)

    'Loop through each Excel file in folder
    Do While filepath <> ""

        If VBA.Right$(filepath, 5) = ".xlsx" Then

            Set wkbSource = Excel.Workbooks.Open(sourceFolder & filepath)
            Set wks = wkbSource.Worksheets(1)
            code = VBA.Left$(wkbSource.Name, 4)


            'If this code doesn't exist in the dictionary yet, add it.
            If Not dict.exists(code) Then
                Set wkbDestination = Excel.Workbooks.Add
                wkbDestination.Worksheets(1).Name = TO_DELETE_SHEET_NAME
                Call dict.Add(code, wkbDestination)
            Else
                Set wkbDestination = dict.Item(code)
            End If

            Call wks.Copy(Before:=wkbDestination.Worksheets(1))
            wkbDestination.Worksheets(1).Name = VBA.Mid$(filepath, 6)

            Call wkbSource.Close(False)

        End If

        filepath = Dir

    Loop


    'Save newly created files.
    For Each varKey In dict.keys
        Set wkbDestination = dict.Item(varKey)

        'Remove empty sheet.
        Set wks = Nothing
        On Error Resume Next
        Set wks = wkbDestination.Worksheets(TO_DELETE_SHEET_NAME)
        On Error GoTo 0

        If Not wks Is Nothing Then wks.Delete


        Call wkbDestination.SaveAs(Filename:=destinationFolder & varKey & ".xlsx")


    Next varKey


    'Restore Excel.Application settings.
    With Excel.Application
        .DisplayAlerts = settingDisplayAlerts
        .SheetsInNewWorkbook = settingSheetsNumber
    End With


End Sub

但是，此代码会打开所有工作簿，并且在大约 60-70 个打开的 excel 文件时我收到一个错误：运行时错误“1004”-对象“工作簿”的“打开”方法失败。

有没有办法让这段代码工作？

Excel 版本是 pro plus 2016。

Answer 1

合并工作簿

• 它将打开每个文件的第一个以唯一的前四个字符开头，并将每个下一个打开文件的第一个工作表复制到第一个打开的文件中，最后将其另存为新文件。
• 不必只有 2 个文件（以相同的四个字符开头），也可以只有一个。
• 调整常量部分中的值。

Option Explicit

Sub mergeWorkbooks()
    
    Const sPath As String = "F:\Test\2021\67077087\"
    Const sPattern As String = "*.xlsx"
    Const dPath As String = "F:\Test\2021\67077087\Destination\"
    Const dName As String = "Master.xlsx"
    Const KeyLen As Long = 4
    
    Dim PatLen As Long: PatLen = Len(sPattern)
    Dim fName As String: fName = Dir(sPath & sPattern)
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Do While Len(fName) > 0
        dict(Left(fName, KeyLen)) = Empty
        fName = Dir
    Loop
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    MkDir dPath
    On Error GoTo 0
    
    Dim wb As Workbook
    Dim Key As Variant
    Dim wsLen As Long
    
    For Each Key In dict.Keys
        Set wb = Nothing
        fName = Dir(sPath & Key & sPattern)
        Do While Len(fName) > 0
            wsLen = Len(fName) - PatLen - KeyLen + 2
            If wb Is Nothing Then
                Set wb = Workbooks.Open(sPath & fName)
                wb.Worksheets(1).Name = Mid(fName, KeyLen, wsLen)
                'Debug.Print wb.Name
            Else
                With Workbooks.Open(sPath & fName)
                    'Debug.Print .Name
                    .Worksheets(1).Name = Mid(fName, KeyLen, wsLen)
                    .Worksheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
                    .Close False
                End With
            End If
            fName = Dir
        Loop
        Application.DisplayAlerts = False
        wb.SaveAs dPath & Key & dName ', xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        wb.Close False
    Next Key

    Application.ScreenUpdating = True

End Sub

姓名测试

使用以下命令将活动工作簿中的所有名称打印到VBE Immediate window (CTRL+G)。

Sub listNames()
    Dim nm As Name
    For Each nm In ActiveWorkbook.Names
        Debug.Print nm.Name
    Next nm
End Sub

首先，检查名称（如果有）是否在某些公式中使用。 使用以下命令删除活动工作簿中的所有名称。

Sub deleteNames()
    Dim nm As Name
    For Each nm In ActiveWorkbook.Names
        nm.Delete
    Next nm
End Sub

Answer 2

未经测试，但这是一种不能同时打开多个文件的方法：

Sub test(sourceFolder As String, destinationFolder As String)
    
    Dim dict As Object, code As String
    Dim colFiles As Collection, f, k, wbNew As Workbook, wb As Workbook

    Set dict = VBA.CreateObject("Scripting.Dictionary")
    
    'ensure trailing "\"
    EnsureSlash sourceFolder
    EnsureSlash destinationFolder
    
    'get a collection of all xlsx files in the source folder
    Set colFiles = allFiles(sourceFolder, "*.xlsx")
    
    If colFiles.Count = 0 Then Exit Sub 'no files
    
    'organize the files into groups according to first four characters of the filename
    For Each f In colFiles
        code = Left(f.Name, 4)
        If Not dict.exists(code) Then Set dict(code) = New Collection 'need new group?
        dict(code).Add f   'add the file to the collection for this code
    Next f
    
    'loop over the groups
    For Each k In dict
        
        Set colFiles = dict(k)  'the files for this code
        Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet) 'one sheet
        
        For Each f In colFiles
            With Workbooks.Open(f.Path)
                .Worksheets(1).Copy after:=wbNew.Sheets(wbNew.Sheets.Count)
                wbNew.Sheets(wbNew.Sheets.Count).Name = Replace(f.Name, ".xlsx", "") 
                .Close False
            End With
        Next f
        
        Application.DisplayAlerts = False
        wbNew.Sheets(1).Delete 'remove the empty sheet
        Application.DisplayAlerts = True
        
        wbNew.SaveAs destinationFolder & k & ".xlsx"
        wbNew.Close
    
    Next k
  
End Sub

'Return all files in `sourceFolder` which match `pattern`
'  as a collection of file objects
Function allFiles(sourceFolder As String, pattern As String) As Collection
    Dim col As New Collection, f
    For Each f In CreateObject("scripting.filesystemobject").getfolder(sourceFolder).Files
        If f.Name Like pattern Then col.Add f
    Next f
    Set allFiles = col
End Function

'Utility - check a path ends in a backslash
' use Application.PathSeparator if needs to be cross-platform
Sub EnsureSlash(ByRef f As String)
    If Right(f, 1) <> "\" Then f = f & "\"
End Sub