Excel 宏不会将工作表复制到新工作簿

Posted 2023-05-07

【中文标题】Excel 宏不会将工作表复制到新工作簿

【英文标题】：Excel Macro Doesn't Copy Worksheets to new Workbook

【发布时间】：2019-04-12 20:49:16

【问题描述】：

我有一个宏，我部分创建并从其他代码拼凑而成。该宏的目的是搜索我的桌面文件夹中名为 Financials 的所有 Excel 文件——它大约有 25 个文件——并将名称中任何位置包含单词 (State) 的所有 Worksheets 复制并粘贴到一个新文档中；将这些工作表合并为 1 个文档并将其保存在我的桌面文件夹中。 该代码仅将空白文档保存到我的文件夹中，不执行其他代码

我已经尝试重新排列代码序列

Sub CombineState()
    Dim wbOpen As Workbook
    Dim wbNew As Workbook
    Const strPath As String = "C:\Users\johnson\Desktop\Financials"
    Dim strExtension As String

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error Resume Next
    ChDir strPath

    strExtension = Dir("*.xlsx")

    Set wbNew = Workbooks.Add
    wbNew.SaveAs Filename:="C:\Users\johnson\Desktop\Final\Financial Metrics for State", FileFormat:=xlWorkbookNormal

    Do While strExtension <> ""
        Set wbOpen = Workbooks.Open(strPath & strExtension)

        Dim checkSheet As Worksheet
        For Each checkSheet In wbOpen.Worksheets
            If UCase$(checkSheet.Name) Like "*State*" Then
                checkSheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
                wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
            End If
        Next

        wbOpen.Close SaveChanges:=False

        strExtension = Dir
    Loop

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    On Error GoTo 0
End Sub

假设，如果 3 个文档在工作表名称中的任何位置包含 State，则新文档将具有 3 个工作表并保存到我的 Final 文件夹中。

【问题讨论】：

删除 On Error Resume Next 并开始修复错误。

UCase$(checkSheet.Name) Like "*State*" 始终为 False，除非您在模块开头有 Option Compare Text 语句。也许您的意思是改用Like "*STATE*"？

【参考方案1】：

你很亲密。见评论：

Sub CombineState()
    Dim wbOpen As Workbook
    Dim wbNew As Workbook
    Const strPath As String = "C:\Users\johnson\Desktop\Financials\" ' Add the backslash at the end
    Dim strExtension As String

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    On Error Resume Next
    ChDir strPath

    strExtension = Dir("*.xlsx")

    Set wbNew = Workbooks.Add
    wbNew.SaveAs Filename:="C:\Users\johnson\Desktop\Final\Financial Metrics for State", FileFormat:=xlWorkbookNormal

    Do While strExtension <> ""
        Set wbOpen = Workbooks.Open(strPath & strExtension)

        Dim checkSheet As Worksheet
        For Each checkSheet In wbOpen.Worksheets
            If UCase$(checkSheet.Name) Like "*STATE*" Then
                checkSheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
                wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
            End If
        Next

        wbOpen.Close SaveChanges:=False

        strExtension = Dir
    Loop

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    On Error GoTo 0
End Sub