Combine worksheets from files

PHOTO EMBED

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