Oct 06 2021 12:34 PM
Below code copy the multiple workbooks all sheets and paste these all sheet into new single workbook as sheets.
I have more than 10 folders which have multiple workbooks with sheets.
Currently what i am doing is, I open the new workbook and paste below code into the workbook then run it, Code ask me to select the folder then i select the folder then code runs and copy all workbooks sheets from particular folder and paste into the open workbooks as sheets then i save this workbook as master workbook into that particular folder.
I repeat this process more than 10 times because i run it for each folder separately.
All i want is when i run the code it should create Master workbook in each folder separately in one go.
Your help will be appreciated.
Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files To merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = FALSE
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = TRUE
Application.Calculation = xlCalculationAutomatic
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
For x = 1 To Sheets.Count
If Worksheets(x).Range("A1").Value <> "" Then
Sheets(x).Name = Worksheets(x).Range("A1").Value
End If
If Worksheets(x).Range("A1").Value <> "" Then
Sheets(x).Range("A1").EntireRow.Delete
End If
Next
End Sub
Oct 06 2021 01:54 PM
Are all those folders subfolders of a single folder?
Oct 07 2021 03:22 AM
Oct 07 2021 05:10 AM
Try this the declarations at the beginning should be at the top of the module (after Option Explicit, if you have that).
Dim wbkCurBook As Workbook
Dim countFiles As Long
Dim countSheets As Long
Sub MergeExcelFiles()
Dim fso As Object
Dim fld As Object
Dim ParentFolder As String
Dim wksCurSheet As Worksheet
With Application.FileDialog(4) ' msoFileDialogFolderPicker
If .Show Then
ParentFolder = .SelectedItems(1)
Else
Beep
Exit Sub
End If
End With
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
countFiles = 0
countSheets = 0
Set wbkCurBook = ActiveWorkbook
Set fso = CreateObject(Class:="Scripting.FileSystemObject")
Set fld = fso.GetFolder(ParentFolder)
Call ProcessFolder(fld)
For Each wksCurSheet In wbkCurBook.Worksheets
If wksCurSheet.Range("A1").Value <> "" Then
wksCurSheet.Name = wksCurSheet.Range("A1").Value
wksCurSheet.Range("A1").EntireRow.Delete
End If
Next wksCurSheet
MsgBox "Processed " & countFiles & " files" & vbCrLf & _
"Merged " & countSheets & " worksheets", _
Title:="Merge Excel files"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub ProcessFolder(fld As Object)
Dim fil As Object
Dim sfl As Object
For Each fil In fld.Files
If LCase(fil.Name) Like "*.xls*" Then
Call ProcessFile(fil)
End If
Next fil
For Each sfl In fld.SubFolders
Call ProcessFolder(sfl)
Next sfl
End Sub
Sub ProcessFile(fil As Object)
Dim wbkSrcBook As Workbook
Dim wksSrcSheet As Worksheet
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fil)
For Each wksSrcSheet In wbkSrcBook.Worksheets
countSheets = countSheets + 1
wksSrcSheet.Copy After:=wbkCurBook.Worksheets(wbkCurBook.Worksheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
End Sub
Oct 07 2021 07:37 AM
Oct 07 2021 11:18 AM
SolutionTry this:
Dim wbkCurBook As Workbook
Dim countFolders As Long
Dim countFiles As Long
Dim countSheets As Long
Sub MergeExcelFiles()
Dim fso As Object
Dim fld As Object
Dim sfl As Object
Dim ParentFolder As String
With Application.FileDialog(4) ' msoFileDialogFolderPicker
If .Show Then
ParentFolder = .SelectedItems(1)
Else
Beep
Exit Sub
End If
End With
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
countFolders = 0
countFiles = 0
countSheets = 0
Set wbkCurBook = ActiveWorkbook
Set fso = CreateObject(Class:="Scripting.FileSystemObject")
Set fld = fso.GetFolder(ParentFolder)
For Each sfl In fld.SubFolders
Call ProcessFolder(sfl)
Next sfl
MsgBox "Processed " & countFiles & " files" & " in " & countFolders & " folders" & _
vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub ProcessFolder(fld As Object)
Dim fil As Object
Dim wksCurSheet As Worksheet
countFolders = countFolders + 1
Set wbkCurBook = Workbooks.Add(Template:=xlWBATWorksheet)
For Each fil In fld.Files
If LCase(fil.Name) Like "*.xls*" Then
Call ProcessFile(fil)
End If
Next fil
Application.DisplayAlerts = False
wbkCurBook.Worksheets(1).Delete
Application.DisplayAlerts = True
For Each wksCurSheet In wbkCurBook.Worksheets
If wksCurSheet.Range("A1").Value <> "" Then
wksCurSheet.Name = wksCurSheet.Range("A1").Value
wksCurSheet.Range("A1").EntireRow.Delete
End If
Next wksCurSheet
wbkCurBook.SaveAs Filename:=fld.Path & "\" & fld.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
wbkCurBook.Close SaveChanges:=False
End Sub
Sub ProcessFile(fil As Object)
Dim wbkSrcBook As Workbook
Dim wksSrcSheet As Worksheet
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fil)
For Each wksSrcSheet In wbkSrcBook.Worksheets
countSheets = countSheets + 1
wksSrcSheet.Copy After:=wbkCurBook.Worksheets(wbkCurBook.Worksheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
End Sub
Oct 08 2021 04:28 AM
Oct 07 2021 11:18 AM
SolutionTry this:
Dim wbkCurBook As Workbook
Dim countFolders As Long
Dim countFiles As Long
Dim countSheets As Long
Sub MergeExcelFiles()
Dim fso As Object
Dim fld As Object
Dim sfl As Object
Dim ParentFolder As String
With Application.FileDialog(4) ' msoFileDialogFolderPicker
If .Show Then
ParentFolder = .SelectedItems(1)
Else
Beep
Exit Sub
End If
End With
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
countFolders = 0
countFiles = 0
countSheets = 0
Set wbkCurBook = ActiveWorkbook
Set fso = CreateObject(Class:="Scripting.FileSystemObject")
Set fld = fso.GetFolder(ParentFolder)
For Each sfl In fld.SubFolders
Call ProcessFolder(sfl)
Next sfl
MsgBox "Processed " & countFiles & " files" & " in " & countFolders & " folders" & _
vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub ProcessFolder(fld As Object)
Dim fil As Object
Dim wksCurSheet As Worksheet
countFolders = countFolders + 1
Set wbkCurBook = Workbooks.Add(Template:=xlWBATWorksheet)
For Each fil In fld.Files
If LCase(fil.Name) Like "*.xls*" Then
Call ProcessFile(fil)
End If
Next fil
Application.DisplayAlerts = False
wbkCurBook.Worksheets(1).Delete
Application.DisplayAlerts = True
For Each wksCurSheet In wbkCurBook.Worksheets
If wksCurSheet.Range("A1").Value <> "" Then
wksCurSheet.Name = wksCurSheet.Range("A1").Value
wksCurSheet.Range("A1").EntireRow.Delete
End If
Next wksCurSheet
wbkCurBook.SaveAs Filename:=fld.Path & "\" & fld.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
wbkCurBook.Close SaveChanges:=False
End Sub
Sub ProcessFile(fil As Object)
Dim wbkSrcBook As Workbook
Dim wksSrcSheet As Worksheet
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fil)
For Each wksSrcSheet In wbkSrcBook.Worksheets
countSheets = countSheets + 1
wksSrcSheet.Copy After:=wbkCurBook.Worksheets(wbkCurBook.Worksheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
End Sub