将具有特定名称的Excel工作表从多个工作簿复制到新工作簿

Question

下午好，

下面的代码将来自多个Excel文件的名为“ CLS”的Excel工作表复制到一个新文档中，并将其命名为CM.xlsx的Financial Metrics。 不幸的是，它不会复制“ CLS”是工作表名称（我也需要包括在内）的一部分的任何工作表。 我曾尝试在搜索时将DIM ws = worksheet添加为通配符的一部分，但无济于事。 我是否应该尝试编写一个'If'字符串来产生所需的结果？ 我不知所措。

Sub CopyWS()
    Dim wbOpen As Workbook
    Dim wbNew As Workbook
    Const strPath As String = "C:\Users\Desktop\Financial 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:\Users\Desktop\Final\Financial Metrics for CLS", FileFormat:=xlWorkbookNormal

            Do While strExtension <> ""
                Set wbOpen = Workbooks.Open(strPath & 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

Answer 1

在这种情况下，您可以循环浏览新打开的工作簿中的每个工作表，并检查名称是否包含字符串CLS 。

   Do While strExtension <> ""

        Set wbOpen = Workbooks.Open(strPath & 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