Merge excel files into a new excel file based on filename

Question

I have a folder containing about 500-600 excel files from a script I have made where the file names end up like this

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

The file names follow that patern, 101a, 102a etc. What i want to do is merge those based on that paternt into 1 excel file. Therefore, the 101a12345.xlsx and 101a67899.xlsx should merge into an 101aMaster.xlsx. All excel files are single sheet.

I have found a sample code here which i am trying to implement: How to merge multiple workbooks into one based on workbooks names

Taken from the link above:

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

However, this code opens all workbooks and at about 60-70 open excel files i receive an error: Run-time Error '1004' - Method 'Open' of object 'Workbooks' failed.

is there a way to make this code work?

Excel version is pro plus 2016.

Answer 1

Merge Workbooks

• It will open the first of each files starting with the unique first four characters, and copy the first worksheet of each next opened file to the first opened file and finally save it as a new file.
• There need not be only 2 files (starting with the same four characters) and there can only be one.
• Adjust the values in the constants section.

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

Test for Names

Use the following to print all names in the active workbook to the 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

First, check if the names (if any) are used in some formulas. Use the following to delete all names in the active workbook.

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