将多个工作簿的 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