Sub CombineWorksheetsFromMultipleFiles()
Dim selectedFiles As FileDialog
Dim selectedFile As Variant
Dim newWorkbook As Workbook
Dim sourceWorkbook As Workbook
Dim ws As Worksheet
Dim newWorksheet As Worksheet
Dim fileName As String
Dim sheetIndex As Integer
' Step 1: Select Excel files
Set selectedFiles = Application.FileDialog(msoFileDialogOpen)
selectedFiles.AllowMultiSelect = True
selectedFiles.Title = "Select Excel Files to Combine"
selectedFiles.Filters.Clear
selectedFiles.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm", 1
If selectedFiles.Show <> -1 Then
MsgBox "No files selected. Exiting macro."
Exit Sub
End If
' Step 2: Create a new workbook
Set newWorkbook = Workbooks.Add
Set newWorksheet = newWorkbook.Sheets(1) ' Change index or name as needed
sheetIndex = 1
' Step 3: Loop through selected files and copy worksheets
For Each selectedFile In selectedFiles.SelectedItems
Set sourceWorkbook = Workbooks.Open(selectedFile)
fileName = sourceWorkbook.Name
For Each ws In sourceWorkbook.Worksheets
ws.Copy after:=newWorkbook.Sheets(newWorkbook.Sheets.Count)
' Rename the copied sheet to include the original file name
newWorkbook.Sheets(newWorkbook.Sheets.Count).Name = Left(fileName, InStrRev(fileName, ".") - 1) & "_" & ws.Name
Next ws
sourceWorkbook.Close SaveChanges:=False
Next selectedFile
' Step 4: Confirmation
MsgBox "Worksheets combined and renamed successfully!", vbInformation
' Clean up
Set selectedFiles = Nothing
Set newWorkbook = Nothing
Set sourceWorkbook = Nothing
Set ws = Nothing
Set newWorksheet = Nothing
End Sub
Preview:
downloadDownload PNG
downloadDownload JPEG
downloadDownload SVG
Tip: You can change the style, width & colours of the snippet with the inspect tool before clicking Download!
Click to optimize width for Twitter