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

【问题标题】：Copy Sheet1 of multiple workbooks to one new workbook将多个工作簿的 Sheet1 复制到一个新工作簿
【发布时间】：2021-10-18 01:27:59
【问题描述】：

我在一个文件夹中有 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

【问题讨论】：

标签： excel vba

【解决方案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

你得到什么输出？

【讨论】：

嗨@TimWilliams，非常感谢您（再次）回答我的问题。我已经运行了这个新代码，直到只复制相同的 10 个工作簿（JJ01 到 JJ10）。请问如何解决名称/扩展名的问题。该文件确实有一个长名称（另存为 JJ01 - 项目标题），但我不希望将文件名保存在新工作簿中。保存为工作表 1/2/3 即可。
嗨@TimWilliams，谢谢。我插入了您详细介绍的最新代码，但这根本没有运行任何东西。甚至没有错误代码？
Debug.Print 输出到 VB 编辑器中的即时窗格（使用 Ctrl+G 显示）...automateexcel.com/vba/debug-print-immediate-window
@DanDonoghue - 这就是为什么我只用* 发布的原因 - 所以如果有不同扩展名的文件就会很明显
也许这些文件包含相同的工作表名称？这意味着它实际上会遍历所有 99 个文件，但会覆盖工作表名称。

【解决方案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

【讨论】：