Question

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

我尝试重新排列代码顺序

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文件夹中。

Answer 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

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

1 个答案: