Combing multiple files into 1 - use file names as tab names

[therealjdj]

Hey everyone,
I am trying to combing multiple excel files into one larger file. Each original file only has one tab. I have searched and found code to do this, however each solution ends up with tabs names Sheet 1, Sheet 1 (2), Sheet 1 (3),...
I really need the tabs to be named per the original file names.

Here is the code I have. What do I need to add to automatically rename the tabs when they are created using the original file name? Thank you!!

Sub MergeMe()

Dim Path As String
Dim Filename As String
Dim Sheet As Worksheet

Path = "C:\Data"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""

Workbooks.Open Filename:=Path & Filename, ReadOnly:=True

    For Each Sheet In ActiveWorkbook.Sheets
        Sheet.Copy After:=ThisWorkbook.Sheets(1)
    Next Sheet

Workbooks(Filename).Close

Filename = Dir()
Loop

End Sub

 

[Marc L]

Hey, a VBA demonstration for starters :​

Sub Demo1()
        Const P = "C:\Data\"
          Dim F$
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    With ThisWorkbook.Sheets
        While .Count > 1:  .Item(.Count).Delete:  Wend
              F = Dir$(P & "*.xlsx")
        While F > ""
            Workbooks.Open P & F, 0
            ActiveWorkbook.ActiveSheet.Copy , .Item(.Count)
           .Item(.Count).Name = Left(ActiveWorkbook.Name, Application.Min(31, Len(ActiveWorkbook.Name) - 5))
            ActiveWorkbook.Close
              F = Dir$
        Wend
    End With
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

 

[therealjdj]

Hmm this doesn't seem to work for me.
All it does is open the first workbook in the identified folder and then it stops.

 

[dmt32]

Hi,
see if this update to your code does what you want

Sub MergeMe()
    
    Dim FilePath    As String
    Dim FileName    As String
    Dim wb          As Workbook
    
    FilePath = "C:\Data"
    FileName = Dir(FilePath & "*.xlsx", vbDirectory)
    
    On Error GoTo myerror
    Application.ScreenUpdating = False
    Do While FileName <> ""
        
        Set wb = Workbooks.Open(FilePath & FileName, False, True)
        wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(1)
        ActiveSheet.Name = Left(Mid(FileName, 1, Len(FileName) - 5), 31)
        wb.Close False
        
        FileName = Dir()
        Set wb = Nothing
    Loop
    
myerror:
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
    
End Sub

Dave