將多個工作簿的 Sheet1 復制到一個新工作簿

Question

我在一個文件夾中有 99 個工作簿。 我想將每個工作表中的 sheet1 復制到一個新工作簿中。 只要每個工作簿/工作表 1 進入目標工作簿中的新工作表，什么順序都沒有關系。

我寫了一個代碼，並試圖對其他代碼進行采樣。 不管怎樣，它只會復制前 10 個工作簿的 sheet1。

這如何在文件夾中的所有工作簿上工作？ 我的目標是將工作表放在一起，以便我可以將某些單元格合並到匯總表中。
我將此代碼放入目標工作簿上的模塊中。

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

編輯：這應該可以防止任何嘗試將多個具有相同名稱的工作表復制到工作簿中的問題。

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

如果您仍然只收到 10 個文件，那么可能是文件名/擴展名有問題？

編輯 - 嘗試列出所有文件：

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

你得到什么輸出？

Answer 2

正如您所想，這是一個文件擴展名。

我現在有這個工作。

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