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