将多个工作簿的 Sheet1 复制到一个新工作簿

Question

I have 99 workbooks in a folder. I want to copy sheet1 from each into a new workbook. It doesn't matter what order as long as each workbook/sheet1 goes onto a new worksheet in the destination workbook.

I have written a code, and tried to sample other codes. No matter what it will only copy sheet1 of the first 10 workbooks.

How can this work on all the workbooks in the folder? My goal is to get the sheets together so I can merge certain cells into a summary sheet.
I put this code into a module on my destination workbook.

Sub combineWorkbooks() 
    Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\" 
    fileName = Dir(Path & "*.xls") 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

Answer 1

EDIT: this should prevent any issues trying to copy multiple sheets with the same name into the workbook.

Sub combineWorkbooks()
    Dim Path, fileName, sheetNum As Long, sheetName As String
    
    Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
    fileName = Dir(Path & "*.xls")
    
    Do While fileName <> ""
        With Workbooks.Open(fileName:=Path & fileName, ReadOnly:=True)
            sheetName = .Worksheets(1).Name
            sheetNum = 1
            'if a worksheet with the same name already exists, add
            ' an incrementing number until the name is unique
            If WorksheetExists(sheetName) Then
                Do While WorksheetExists(sheetName & sheetNum)
                    sheetNum = sheetNum + 1
                Loop
                .Worksheets(1).Name = sheetName & sheetNum 'rename if required
            End If
            'copy to end of sheets
            .Worksheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            .Close
        End With
        fileName = Dir()
    Loop
End Sub

Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

If you're still getting only 10 files then maybe it's an issue with the file names/extensions?

Edit - try listing all of the files:

Dim Path, fileName
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*")
Do While fileName <> ""
    Debug.Print fileName
    fileName = Dir()
Loop

What output do you get?

Answer 2

It was a file name extension, as you thought.

I now have this working.

Sub CombineFiles()
     
    Dim Path            As String
    Dim FileName        As String
    Dim Wkb             As Workbook
    Dim WS              As Worksheet
     
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0800-JJ0899" 'Change as needed
    FileName = Dir(Path & "\*.xlsx", vbNormal)
    Do Until FileName = ""
        Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
        For Each WS In Wkb.Worksheets
            WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Next WS
        Wkb.Close False
        FileName = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True
     
End Sub