Блог

Добрый день,

Приведенный ниже код копирует листы Excel с именем «CLS» из нескольких файлов Excel в новый документ и присваивает ему финансовые показатели для CM.xlsx. К сожалению, он не копирует ни одного листа, где «CLS» является частью названия листа (которое мне также необходимо включить). Я попытался добавить DIM ws = worksheet как часть подстановочного знака при поиске, но безрезультатно. Должен ли я попробовать вместо этого написать строку ‘If’, чтобы получить желаемый результат? Я в растерянности.

 Sub CopyWS()
    Dim wbOpen As Workbook
    Dim wbNew As Workbook
    Const strPath As String = "C:UsersDesktopFinancial Monthly Report"
    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:UsersDesktopFinalFinancial Metrics for CLS", FileFormat:=xlWorkbookNormal

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

                With wbOpen
                    .Sheets("CLS").Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
                    wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
                    .Close SaveChanges:=False
                End With

                strExtension = Dir
            Loop

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    On Error GoTo 0
End Sub
  

В этом случае вы можете просмотреть каждый лист во вновь открытой книге и проверить, содержит ли имя строку CLS .

    Do While strExtension <> ""

        Set wbOpen = Workbooks.Open(strPath amp; strExtension)

        Dim checkSheet as Worksheet
        For each checkSheet in wbOpen.Worksheets
            If UCase$(checkSheet.Name) Like "*CLS*" 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