Excel VBA将文件夹中多个文件中的多张图纸复制到一个文件中的多张图纸中

我一直在试图找到一个“合并”excel文件的快速解决方案，遇到了至少十几个不同的代码，尝试记录我自己的宏并对其进行修改（而不是一系列的工作表名称试图选择批次等）。所有这些都没有达到我想要的效果，大多数根本不起作用

背景如下： 我在一个文件夹（“C:\Zoltan\TEST\”）中有很多文件，大多数都有多张工作表。我想抄写

• 工作表名称中没有“邮寄”的所有工作表
• 来自文件名中没有“打印”的所有文件
• 放入一个文件（“C:\Zoltan\TEST.xlsx”），保持工作表与源文件中的工作表分开
• 只有当工作表名称已经存在时，我才想给它一个日期戳（例如，从2105年8月28日创建的“E8795 NTI邮寄订单.XLSX”中名为“NTI UK（150）”的工作表变为“NTI UK（150）20150828”

下面是我得到的，不幸的是，这似乎没有做任何事情。目前，我正在从打开的目标文件运行宏（这不是什么问题，我很高兴这样做）。我还缺少“打印”排除（而不是“邮寄”包含）在文件名和整个日期戳位中，但这些将是我的下一步：

Sub CombineSheets()
Dim sPath As String
Dim sFname As String
Dim wbk As Workbook
Dim wSht As Worksheet

Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = "C:\Zoltan\TEST\"
ChDir sPath
sFname = "*Mailing*"
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
Do Until sFname = ""
    Set wbk = Workbooks.Open(sFname)
    Windows(sFname).Activate
    For Each ws In Sheets
        If Not ws.Name Like "*Mailing*" Then ws.Copy Before:=ThisWorkbook.Sheets(1)
        wbk.Close False
        sFname = Dir()
    Next
Loop
ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

我希望我已经以一种清晰易懂的方式解决了这个问题，但为了安全起见，如果我手动解决这个问题，它将如下所示：

打开测试文件

打开一个没有单词的源文件 文件名中的“打印”

突出显示所有未显示的图纸 在工作表名称中有“邮寄”（这些只是表格，不是数据 床单，我不需要）

右键单击并“移动或复制”，勾选 “创建副本”，选择TEST.xlsx并选择Sheet1

关闭源文件并转到下一个

请注意，如果以上是纯粹的屠杀，那是因为我缺乏足够的VBA技能。我倾向于查看其他人的代码，或记录宏，将它们拆开，然后尝试理解它们，并按我希望的方式将它们重新组合在一起

哪里出错？有没有更简单的编码方法？注意，我宁愿复制整个工作表，也不愿突出显示工作表中的范围，并将这些范围放入目标文件中的新工作表中，就像大多数代码（我遇到过）一样

---

许多感谢您的代码是否正在创建您找到的工作表的副本？您没有确切解释发生了什么或没有发生什么。您的sFname=Dir（）命令放错了位置…我建议您只是自动设置名称，而不是尝试查看名称是否存在

文件名很简单，请在do循环中使用以下内容：

Set wbk = Workbooks.Open(sFname)
Windows(sFname).Activate
For Each ws In Sheets
    If Not sFname Like "*printing*" Then
        If Not ws.Name Like "*Mailing*" Then
            ws.Copy Before:=ThisWorkbook.Sheets(1)
            ThisWorkbook.Sheets(1).Name = ThisWorkbook.Sheets(1).Name + Format(Now(), "yyyyMMdd-hhmm")
        End If
        wbk.Close
    End If
Next
sFname = Dir()

一些修复：

Sub CombineSheets()

    Const sPath As String = "C:\Zoltan\TEST\"
    Dim sFname As String
    Dim wbk As Workbook
    Dim wSht As Worksheet

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    'sPath already has a trailing \ - don't add another...
    sFname = Dir(sPath & "*Mailing*.xl*", vbNormal)

    Do Until sFname = ""

        'Dir only gives you the filename - use full path below
        Set wbk = Workbooks.Open(sPath & sFname)

        For Each wSht In wbk.WorkSheets
            If Not wSht.Name Like "*Mailing*" Then 
                wSht.Copy Before:=ThisWorkbook.Sheets(1)
            End If
        Next
        'moved these lines out of the sheets loop
        wbk.Close False
        sFname = Dir()

    Loop

    ThisWorkbook.Save
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

---

您正在调用

Dir（）

并在工作表的内部循环中关闭源工作簿-您应该将这些行移到

loop

之前。嗨，蒂姆，谢谢您的评论，我已经将这些行移出了循环，它抛出了一个运行时错误，表示找不到[…].xlsx文件。我尝试使用sFname=Dir（sPath&sFname&“.xl*”，vbNormal）因为sPath在测试后已经包含反斜杠，但它只是删除了相同的错误消息。它找不到的文件是C:\Zoltan\TEST \-中的第一个文件，它是否在某个地方更改了目录，并试图在获得文件名后在另一个文件夹中查找该文件？很抱歉，我不是很清楚：代码没有任何对用户可见的内容我还没有达到运行它，输出每个变量，并试图使每个步骤产生一个可见的结果的程度，我很快就会这样做。你说的“自动设置名称”是什么意思？通过自动设置名称，我的意思是创建新的工作表并立即给它一个唯一的名称，正如我在上述代码的内部If中所做的那样。这比试图确定是否已经存在具有特定名称的工作表要简单得多。抱歉@PKatona，该公司正在进行一次收购，但不允许我返回此问题e、 它仍然在桌面上，我会尽快测试发布在这里的解决方案并回复/投票等！抱歉@Tim Williams，公司正在进行收购，不允许我回到这个问题。它仍然在桌面上，我会尽快测试发布在这里的解决方案并回复/投票等！