Combine multiple Excel workbooks into individual Excel workbooks based on filenames - VBA

[wakerider017]

I have multiple workbooks saved in C:\Temp.

They look like:

• AAAA_1.xlsx
• AAAA_2.xlsx
• AAAA_3.xlsx
• BBBB_1.xksx
• BBBB_2.xksx
• CCCC_1.xlsx
• CCCC_2.xlsx
• CCCC_3.xlsx
• CCCC_4.xlsx
• etc.

I want to combine these files into master workbooks, so in the above example, I would have master file AAAA with data from AAAA_1, AAAA_2 and AAAA_3, a master file BBBB with data from BBBB_1 and BBBB_2, etc.

Below is my current VBA. I am able to search for prefix "AAAA" and that creates a new master file with all tabs from AAAA_1, AAAA_2 and AAAA_3, but then how to I start over (automatically) and create master files for all of the other prefixes that exist in C:\Temp? Thanks from a VBA rookie!

Sub Merge()
Path = "C:\Temp\"
Filename = Dir(Path & "AAAA" & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
 For Each Sheet In ActiveWorkbook.Sheets
   Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
 Application.DisplayAlerts = False
 Workbooks(Filename).Close
 Filename = Dir()
'Save workbook
Loop
 Application.DisplayAlerts = True
 
ActiveWorkbook.SaveAs Filename:="C:\Temp\File_" & Range("A1") & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
End Sub

 

[DanteAmor]

I propose the following. The macro will read the name of all the files in the Temp path and create all the master books according to the first 4 letters of all the files.
The new master files will be saved in another folder, for example Temp\books, just create the new folder and update the name in the macro.

Put the macro in a new workbook and save the workbook in a folder other than \Temp

Try:

Sub Merge()
  Dim sPath1 As String, sPath2 As String, sFile As String, prefix As String
  Dim dic As Object, ky As Variant, vBooks As Variant
  Dim wb2 As Workbook, wb3 As Workbook, sh As Worksheet
  Dim i As Long
  '
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '
  sPath1 = "C:\Temp\"          'source path
  sPath2 = "C:\Temp\books\"    'destination path
  '
  sFile = Dir(sFile & "*.xlsx")
  Set dic = CreateObject("Scripting.Dictionary")
  '
  Do While sFile <> ""
    prefix = Left(sFile, 4)
    dic(prefix) = dic(prefix) & "|" & sFile
    sFile = Dir()
  Loop
  '
  For Each ky In dic.keys
    Set wb2 = Workbooks.Add(xlWBATWorksheet)
    vBooks = Split(dic(ky), "|")
    For i = 1 To UBound(vBooks)
      Set wb3 = Workbooks.Open(sPath1 & vBooks(i), False, True)
      For Each sh In wb3.Sheets
        sh.Copy After:=wb2.Sheets(1)
      Next sh
      wb3.Close False
    Next i
    wb2.Sheets(1).Delete
    wb2.SaveAs sPath2 & ky & ".xlsx", xlOpenXMLWorkbook
    wb2.Close False
  Next ky
  '
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  MsgBox "End"
End Sub

 

[wakerider017]

I propose the following. The macro will read the name of all the files in the Temp path and create all the master books according to the first 4 letters of all the files.
The new master files will be saved in another folder, for example Temp\books, just create the new folder and update the name in the macro.

Put the macro in a new workbook and save the workbook in a folder other than \Temp

Try:

Sub Merge()
  Dim sPath1 As String, sPath2 As String, sFile As String, prefix As String
  Dim dic As Object, ky As Variant, vBooks As Variant
  Dim wb2 As Workbook, wb3 As Workbook, sh As Worksheet
  Dim i As Long
  '
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  '
  sPath1 = "C:\Temp\"          'source path
  sPath2 = "C:\Temp\books\"    'destination path
  '
  sFile = Dir(sFile & "*.xlsx")
  Set dic = CreateObject("Scripting.Dictionary")
  '
  Do While sFile <> ""
    prefix = Left(sFile, 4)
    dic(prefix) = dic(prefix) & "|" & sFile
    sFile = Dir()
  Loop
  '
  For Each ky In dic.keys
    Set wb2 = Workbooks.Add(xlWBATWorksheet)
    vBooks = Split(dic(ky), "|")
    For i = 1 To UBound(vBooks)
      Set wb3 = Workbooks.Open(sPath1 & vBooks(i), False, True)
      For Each sh In wb3.Sheets
        sh.Copy After:=wb2.Sheets(1)
      Next sh
      wb3.Close False
    Next i
    wb2.Sheets(1).Delete
    wb2.SaveAs sPath2 & ky & ".xlsx", xlOpenXMLWorkbook
    wb2.Close False
  Next ky
  '
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  MsgBox "End"
End Sub

Thank you, but this code is throwing an error at this line:

Set wb3 = Workbooks.Open(sPath1 & vBooks(i), False, True)

"Run-time error 1004
Sorry, we couldn't fine C:\Temp\Gas Prices.xlsx. Is it possible it was moved, renamed or deleted?"


Gas Prices.xlsx is a file I saved in my documents folder a few months ago.


Edit, I added your code to a new module in a blank workbook. I tried running the workbook from the Desktop as well as C:\Temp - and had the same trouble.

 

[wakerider017]

I ended up using this code that someone helped me with. It is able to look for prefixes based on a certain character (underscore in this case). It has a parameter to look for the 1st, 2nd, 3rd, etc underscore. It can also be set to fixed mode where it uses the first n characters of a file name as a prefix. I wanted to share this here in case someone else might find this useful in the future.

Option Explicit

Sub consolidate()

    Const FOLDER = "C:\Temp\"

    Const SEP_COUNT = 0 'set to 0 to use fixed width
    Const SEP = "_"
    Const FIXED_WIDTH = 3 '
   
    Dim wb As Workbook, wbMaster As Workbook, ws As Worksheet
    Dim dict As Object, k, c As Collection, ar, f
    Dim m As Integer, n As Integer
    Dim sFile As String, s As String
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' build collections
    sFile = Dir(FOLDER & "*.xlsx")
    Do While Len(sFile) > 0
        k = ""
       
        ' avoid masters
        If sFile Like "Master*" Then
            ' do nothing
        ElseIf SEP_COUNT > 0 Then
            If InStr(sFile, SEP) > 0 Then
                ' example INV_1104092_05_31_2021_000.xlsx
                ar = Split(sFile, SEP, SEP_COUNT + 1)
                If UBound(ar) >= SEP_COUNT Then
                     k = ar(0)
                     For n = 1 To SEP_COUNT - 1
                         k = k & "_" & ar(n)
                     Next
                End If
             End If
        ElseIf FIXED_WIDTH > 0 Then
            k = Left(sFile, FIXED_WIDTH)
        End If

        If Len(k) > 0 Then
            If Not dict.exists(k) Then
                dict.Add k, New Collection
            End If
            Set c = dict.Item(k)
            c.Add Trim(sFile), CStr(c.Count + 1)
        End If

        sFile = Dir
    Loop

    ' copy sheets
    Application.ScreenUpdating = False
    For Each k In dict
        ' create new master
        Set wbMaster = Workbooks.Add
        m = wbMaster.Sheets.Count
        n = m
        For Each f In dict(k) ' files in collection
            Set wb = Workbooks.Open(FOLDER & f, 1, 1)
            s = Replace(Mid(f, Len(k) + 1), ".xlsx", "")
            ' remove _ from front
            If SEP_COUNT > 0 And Left(s, 1) = "_" Then s = Mid(s, 2)
            For Each ws In wb.Sheets
                ws.Copy After:=wbMaster.Sheets(n)
                n = n + 1
                wbMaster.Sheets(n).Name = s & "_" & ws.Name
            Next
            wb.Close False
        Next

        ' delete initial sheets
        Application.DisplayAlerts = False
        For n = m To 1 Step -1
            wbMaster.Sheets(n).Delete
        Next
        Application.DisplayAlerts = True
     
        ' save master
        wbMaster.SaveAs FOLDER & "Master_" & k & ".xlsx", _
               FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        wbMaster.Close False
    Next
    ' end
    Application.ScreenUpdating = True
    MsgBox dict.Count & " master files created", vbInformation

End Sub

 

[DanteAmor]

Thank you, but this code is throwing an error at this line:
Set wb3 = Workbooks.Open(sPath1 & vBooks(i), False, True)
"Run-time error 1004
Sorry, we couldn't fine C:\Temp\Gas Prices.xlsx. Is it possible it was moved, renamed or deleted?"

Sorry, it's my fault

Change this line:

sFile = Dir(sFile & "*.xlsx")

for this:

sFile = Dir(sPath1 & "*.xlsx")

If you want prefixes of 3, change the 4 on this line:
prefix = Left(sFile, 4)

 

[DanteAmor]

The macro updated with 3 characters and the file name prefixed with "Master_"

Sub Merge()
  Dim sPath1 As String, sPath2 As String, sFile As String, prefix As String
  Dim dic As Object, ky As Variant, vBooks As Variant
  Dim wb2 As Workbook, wb3 As Workbook, sh As Worksheet
  Dim i As Long
  '
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  sPath1 = "C:\Temp\"          'source path
  sPath2 = "C:\Temp\books\"    'destination path
  sFile = Dir(sPath1 & "*.xlsx")
  Set dic = CreateObject("Scripting.Dictionary")
  '
  Do While sFile <> ""
    prefix = Left(sFile, 3)
    dic(prefix) = dic(prefix) & "|" & sFile
    sFile = Dir()
  Loop
  '
  For Each ky In dic.keys
    Set wb2 = Workbooks.Add(xlWBATWorksheet)
    vBooks = Split(dic(ky), "|")
    For i = 1 To UBound(vBooks)
      Set wb3 = Workbooks.Open(sPath1 & vBooks(i), False, True)
      For Each sh In wb3.Sheets
        sh.Copy After:=wb2.Sheets(1)
      Next sh
      wb3.Close False
    Next i
    wb2.Sheets(1).Delete
    wb2.SaveAs sPath2 & "Master_" & ky & ".xlsx", xlOpenXMLWorkbook
    wb2.Close False
  Next ky
  MsgBox "Created files: " & dic.Count
End Sub