updating a macro to combine excel sheets and rename them

[leighthomas140]

Hi all,
I am hoping someone can help me out with a macro that I just cannot get to work.

I have multiple excel files each containing just 1 sheet. I am trying to write a macro that will merge all files into 1 multi sheet file and name each sheet with the name of the source file it came from.

I have been able to successfully merge all files but the renaming of the sheet names is getting me stuck. Below is my code that doesn't work, any help is really appreciated. Also I would not be offended if someone tells me to scrap my code all together for a better alternative

many thanks

Leigh

Sub MergeSelectedFiles()
    
    Dim selectedFiles As FileDialog
    Dim fileName As String
    Dim wb As Workbook
    Dim sourceFileName As String
    Dim mergedSheet As Worksheet
    
    Set selectedFiles = Application.FileDialog(msoFileDialogFilePicker)
    
    With selectedFiles
        .AllowMultiSelect = True
        .Title = "Select the files to merge"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
        .Show
    End With
    
    If selectedFiles.SelectedItems.Count > 0 Then
        
        Set wb = Workbooks.Add 'Create a new workbook to merge the selected files
        
        For Each fileName In selectedFiles.SelectedItems
            sourceFileName = Left(Right(fileName, Len(fileName) - InStrRev(fileName, "\")), InStrRev(Right(fileName, Len(fileName) - InStrRev(fileName, "\")), ".") - 1)
            Workbooks.Open fileName, ReadOnly:=True
            Set mergedSheet = ActiveWorkbook.Sheets(1)
            mergedSheet.Copy After:=wb.Sheets(wb.Sheets.Count)
            wb.Sheets(wb.Sheets.Count).Name = ActiveWorkbook.Name
           ActiveWorkbook.Close False
        Next fileName
        
        wb.SaveAs "MergedFile.xlsx"
        wb.Close
        
        MsgBox "Selected files have been merged successfully!", vbInformation, "Merge Files"
    Else
        MsgBox "No files were selected.", vbExclamation, "Merge Files"
    End If

End Sub

 

[I_know_nuffin]

Hi Leigh

try the below

Sub MergeSelectedFiles()
    
    Dim selectedFiles As FileDialog
    Dim fileName As String, path As String, openfilename As String
    Dim lngCount As Long
    Dim wb As Workbook, wbro As Workbook
    Dim sourceFileName As String
    Dim mergedSheet As Worksheet
    
    path = "C:\xyz\" '= Path to save merged file into"
    

    
    Set selectedFiles = Application.FileDialog(msoFileDialogFilePicker)
    
    With selectedFiles
        .AllowMultiSelect = True
        .Title = "Select the files to merge"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
        .Show
    End With
    
    If selectedFiles.SelectedItems.Count > 0 Then
        
        Set wb = Workbooks.Add 'Create a new workbook to merge the selected files
        
     'Stop
        
        For lngCount = 1 To selectedFiles.SelectedItems.Count
        fileName = selectedFiles.SelectedItems(lngCount)
        Debug.Print fileName
            sourceFileName = Left(Right(fileName, Len(fileName) - InStrRev(fileName, "\")), InStrRev(Right(fileName, Len(fileName) - InStrRev(fileName, "\")), ".") - 1)
            openfilename = Right(fileName, Len(fileName) - InStrRev(fileName, "\"))
        Debug.Print sourceFileName
            Workbooks.Open fileName, ReadOnly:=True
            Set mergedSheet = ActiveWorkbook.Sheets(1)
            mergedSheet.Copy After:=wb.Sheets(wb.Sheets.Count)
            wb.Sheets(wb.Sheets.Count).Name = sourceFileName
            Workbooks(openfilename).Close False
        Next lngCount
        
        wb.SaveAs path & "MergedFile.xlsx"
        wb.Close
        
        MsgBox "Selected files have been merged successfully!", vbInformation, "Merge Files"
    Else
        MsgBox "No files were selected.", vbExclamation, "Merge Files"
    End If

End Sub

 

[leighthomas140]

@I_know_nuffin this works perfectly thank you so much for assist!!