Combine worksheets from files
Wed Jul 10 2024 06:12:41 GMT+0000 (Coordinated Universal Time)
Saved by
@miskat80
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
content_copyCOPY
Comments