使用VBA将文件夹中每个工作簿中的一张工作表合并到一个工作簿中

Question

我的任务是将每个工作簿中的一张工作表（数量可能不同）从一个文件夹合并到一个主工作簿中。

每个工作簿都基于一个模板，所以它们看起来都一样，每个都有两张纸。

我需要复制其中一张名为“填写”的表格。

结果应该是：主数据工作簿，其中包含与文件夹中的文件一样多的工作表，并且每个工作表都包含“填写”工作表中的数据。

Sub MergeWorkbooks()

Dim FolderPath As String
Dim File As String

FolderPath = "C:\Users\" & Environ("username") & "\Downloads\BH\"

File = Dir(FolderPath)

Do While File <> ""

    Workbooks.Open FolderPath & File
    ActiveWorkbook.Worksheets("Fill this out").Copy _
      after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ActiveSheet.Name = File
    Workbook.Close FolderPath & File
            
    File = Dir()

Loop

End Sub 

这将复制第一个文件，然后弹出错误 400。

此外，新的工作表名称是：“填写”而不是文件名。

Answer 1

您可以使用此代码打开该文件夹中的文件，并关闭每个文件以消除各自的保存事件。注意 "*.xl*" 过滤器只允许打开 Excel 文件：

Option Explicit

Sub MergeWorkbooks()
    Dim FolderPath As String
    Dim File As String

    FolderPath = "C:Users" & Environ("username") & "DownloadsBH"

    File = Dir(FolderPath & "*.xl*")

    Do While File <> ""

        Workbooks.Open FolderPath & File
        ActiveWorkbook.Worksheets("Fill this out").Copy _
            after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        ActiveSheet.Name = File
        Workbooks(File).Close savechanges:=False
            
        File = Dir()

    Loop

End Sub

---

编辑

试试这个修改后的代码，它更自信地处理源工作簿（设置工作簿对象）：

Option Explicit

Sub MergeWorkbooks()
    Dim FolderPath As String
    Dim File As String
    Dim objWB As Excel.Workbook

    FolderPath = "C:Users" & Environ("username") & "DownloadsBH"

    File = Dir(FolderPath & "*.xl*")

    Do While File <> ""

        Set objWB = Workbooks.Open(FolderPath & File)
       
        If Not objWB Is Nothing Then
            objWB.Worksheets("Fill this out").Copy _
                after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            ThisWorkbook.Sheets("Fill this out").Name = File
            objWB.Close savechanges:=False
        End If
   
        File = Dir()

    Loop

End Sub