Макрос Excel не копирует рабочие листы в новую рабочую книгу

Question

У меня есть макрос, который я частично создал и собрал воедино из других кодов. Цель макроса - найти все файлы Excel в папке на рабочем столе под названием «Финансы» - в ней содержится примерно 25 файлов - и скопировать и вставить в новый документ все рабочие листы, в которых есть слово (состояние) в любом месте имени; объедините эти рабочие листы в один документ и сохраните его в папке рабочего стола с именем 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