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.

I think your problem is that you're opening two workbooks in the first Do loop but only closing one of them. If you fix that, the code will probably not error out, but I suspect it's a long way from doing what you want it to do. — Nicholas Hunter, Apr 13 '21 at 15:41

VBasic2008 · Accepted Answer · 2021-04-14T08:57:05.553

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

Thanks for this VBasic2008! It worked but however i received a message: The name 'aname' already exists. Click yes to use that version of the name, or click No to rename the version of 'aname' you're moving or copying. it popped 2-3 times and after that it stoped. The script executed sucesffulyl after that and quite fast. is there a way in this script to add in the merged workbooks to keep the name after the 101a 102b etc so the new excel which will be the master file will have 2 sheets named a12345 and a167899 ? — KRStam, Apr 13 '21 at 20:41
Implemented additional functionality of renaming the worksheets. — VBasic2008, Apr 13 '21 at 21:32
It works, however I still receive the message: The name 'aname' already exists. Click yes to use that version of the name, or click No to rename the version of 'aname' you're moving or copying. If we can solve that it would be working 100%! Thank you for your time! — KRStam, Apr 14 '21 at 06:27
How would I know what `aname` is? Would you care to explain? Try to move `Application.DisplayAlerts = False` right below `For Each Key In dict.Keys`. — VBasic2008, Apr 14 '21 at 06:50
I really have no clue what aname is, I dont see it in the VBA Code nor in the workbook. I tried the False option as you suggested, the message appeared 2-3 times where I clicked OK and then after that it stoped appearing and the process completed. Is that related to the formulas or anything else within the workbook? Thank you massively for your time. This is really helpful! — KRStam, Apr 14 '21 at 08:42
Maybe you have a defined name in the first few worksheets (workbooks). If you're not using it in the formulas, delete it using the `Name Manager`. — VBasic2008, Apr 14 '21 at 08:47
Thank you i have deleted some unused names in the formula manager and it didn't appear! Thank you for your time! — KRStam, Apr 14 '21 at 10:25

Tim Williams · Answer 2 · 2021-04-13T21:24:48.410

Untested but here's one approach where you don't have multiple files open at the same time:

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

Merge excel files into a new excel file based on filename

2 Answers2

Merge Workbooks

Linked