I have multiple workbooks saved in C:\Temp.
They look like:
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
Using a dictionary and collections. Scans the directory to compile a list of master workbooks first and then uses the collections to open and copy the sheets.
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
Convert your current sub to accept the letter pattern and call it by a main one feeding all wanted letters
Sub Merge()
Const letters As String = "ABCDEFG" ' collect all wanted initial letters
Dim iLetter As Long
For iLetter = 1 To Len(letters) ' loop through letters
MergeLetter String(4,Mid$(letters, iLetter, 1))
Next
End Sub
and here's your original Merge()
sub, I adapted for the task:
Sub MergeLetter(letter As String)
Dim masterWb As Workbook
Set masterWb = Workbooks.Add 'open a new "master" workbook
Dim path As String
path = "C:\Temp\"
Dim fileName As String
fileName = Dir(path & letter & "*.xlsx")
Do While fileName <> vbNullString
With Workbooks.Open(fileName:=path & fileName, ReadOnly:=True)
Dim sh As Worksheet
For Each sh In .Worksheets
sh.Copy After:=masterWb.Sheets(1)
Next
.Close
End With
fileName = Dir()
Loop
With masterWb
.SaveAs fileName:=path & letter & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close False
End With
End Sub
as you see, I also adopted some stylistic changes, one of them being my personal code indentation pattern, which you may found userful or not
FolderPath
) or at least a file whose name has none of the prefixes.Option Explicit
Sub mergeSheets()
Const FolderPath As String = "C:\Temp\"
Const PrefixesList As String = "AAAA,BBBB,CCCC"
Dim Prefixes() As String: Prefixes = Split(PrefixesList, ",")
Dim swb As Workbook
Dim dwb As Workbook
Dim sh As Object
Dim fName As String
Dim n As Long
Dim dshCount As Long
Application.ScreenUpdating = False
For n = 0 To UBound(Prefixes)
fName = Dir(FolderPath & Prefixes(n) & "*.xlsx")
dshCount = 0
Do Until Len(fName) = 0
Set swb = Workbooks.Open(FolderPath & fName, , True)
For Each sh In swb.Sheets ' charts and what not included
If dshCount = 0 Then
sh.Copy ' creates a new workbook containing one sheet
Set dwb = ActiveWorkbook
Else
sh.Copy After:=dwb.Sheets(dshCount)
End If
dshCount = dshCount + 1
Next sh
swb.Close SaveChanges:=False
fName = Dir
Loop
' Maybe you wanna rather do '... & Prefixes(n) & ".xlsx",...'
dwb.SaveAs "C:\Temp\File_" & dwb.WorkSheets(1).Range("A1") & ".xlsx", _
xlOpenXMLWorkbook, , , , False
dwb.Close
Next n
Application.ScreenUpdating = True
End Sub
Create a class
Named WorkbookMerger
and add the following code into it
Option Explicit
''Add/check Tools> Reference> Microsoft Scripting Runtime
Private FileSysObject As Scripting.FileSystemObject
Private Fullfolder As Scripting.Folder
Private SingleFile As Scripting.File
Private dict As Scripting.Dictionary
Private ProccessedFolder As String
Private Const Delim As String = "_"
Private Const SaveInFolder As String = "ProccessedFiles"
Public Function Execute(ByVal BasePath As String) As Boolean
Set Fullfolder = FileSysObject.GetFolder(BasePath)
ProccessedFolder = FileSysObject.BuildPath(BasePath, SaveInFolder)
Execute = False
If Not FileSysObject.FolderExists(ProccessedFolder) Then
FileSysObject.CreateFolder (ProccessedFolder)
End If
If ReadPatterns Is Nothing Then
Exit Function
Else
ProcessFiles
End If
Execute = True
End Function
Private Function ReadPatterns() As Scripting.Dictionary
For Each SingleFile In Fullfolder.Files
Dim Pattern As String
Pattern = Split(SingleFile.Name, Delim)(0) 'change delimeter
On Error Resume Next
If Not dict.Exists(Pattern) Then dict.Add Pattern, CStr(Pattern)
Next SingleFile
Set ReadPatterns = dict
End Function
Private Sub ProcessFiles()
Dim key As Variant
For Each key In dict
'loop through all patterns in dict and process each file if it matches
Dim masterWb As Workbook
Dim masterwbName As String
masterwbName = ProccessedFolder & "\" & key & ".xlsx"
If FileSysObject.FileExists(masterwbName) Then
Set masterWb = Workbooks.Open(masterwbName)
Else
Set masterWb = Workbooks.Add
End If
For Each SingleFile In Fullfolder.Files
With SingleFile
If .Name Like key & "*" Then
Dim Wsheet As Worksheet
Dim wb As Workbook
Set wb = Workbooks.Open(Fullfolder.Path & "\" & SingleFile.Name, ReadOnly:=True)
For Each Wsheet In wb.Worksheets
Wsheet.Copy after:=masterWb.Sheets(1)
Next Wsheet
wb.Close False
'close file without saving any changes
End If
End With
Next SingleFile
With masterWb
.SaveAs masterwbName, xlOpenXMLWorkbook
.Close True
End With
Next key
End Sub
Private Sub Class_Initialize()
Set FileSysObject = New Scripting.FileSystemObject
Set dict = New Scripting.Dictionary
End Sub
Now in any module
add the following code
Public Sub Testing()
Dim WMerger As WorkbookMerger
Set WMerger = New WorkbookMerger
On Error GoTo ErrorExit:
With Application
'.Calculation = xlCalculationAutomatic
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableCancelKey = xlInterrupt
End With
If WMerger.Execute("C:\Temp") Then MsgBox "Completed"
ErrorExit:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub
SaveInFolder
it creates a sub-folder under basepath where all processed files will be stored. Delim
.I tried with 20 different files with different patterns and it works as expected. Let me now if it works.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.