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

wakerider017

Board Regular
Joined
Jun 10, 2015
Messages
77
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!

VBA Code:
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
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,262
Office Version
  1. 2007
Platform
  1. Windows
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:

VBA Code:
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

Board Regular
Joined
Jun 10, 2015
Messages
77
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:

VBA Code:
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

Board Regular
Joined
Jun 10, 2015
Messages
77
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.

VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
13,262
Office Version
  1. 2007
Platform
  1. Windows
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:
VBA Code:
sFile = Dir(sFile & "*.xlsx")

for this:

VBA Code:
sFile = Dir(sPath1 & "*.xlsx")

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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,262
Office Version
  1. 2007
Platform
  1. Windows
The macro updated with 3 characters and the file name prefixed with "Master_"

VBA Code:
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
 

Forum statistics

Threads
1,136,444
Messages
5,675,895
Members
419,591
Latest member
mersanko

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top