寻找VBA解决方案：如何根据工作表标题有选择地复制和保存工作表

Question

我的组织发布了 Excel 格式的每周报告，其中包含 60 多个工作表，每个工作表的标题都有一个活动缩写。我只对特定的工作表感兴趣。目前，我手动搜索这些工作表并将其复制到新的工作簿中。现有的 VBA 解决方案似乎需要在数组中预定义工作表名称，这在我的情况下不起作用，因为当没有活动时，工作簿中不包含标题为活动代码的相应工作表。

我正在寻找可以：

• 根据名称中的特定活动代码识别工作表（我有完整的列表）
• 当工作表不在工作簿中时跳过名称
• 将识别的工作表复制并保存到新工作簿中

理想情况下，最终用户能够选择保存新工作簿的目标位置，而不是自动保存在原始工作簿的路径中。

非常感谢！

我是VBA新手，所以我尝试通过合并在网上找到的多个代码来修改代码，但没有成功。对于测试，我只使用了三个工作表名称（实际运行将拉出 20 个）。标题为“BBA”和“BBB”的工作表在工作簿中，而“BBV”不在工作簿中。我当然愿意走不同的方向，因为我确信有一种更清晰的方式来编写它。

Sub TwoSheetsAndYourOut()
    Dim NewName As String
    Dim nm As Name
    Dim ws As Worksheet
    Dim MyArr, j As Long
     
    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
    "New sheets will be pasted as values, named ranges removed" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub
     
    Application.ScreenUpdating = False
         
         '       Copy specific sheets
         '       *SET THE SHEET NAMES TO COPY BELOW*
         '       Array("Sheet Name", "Another sheet name", "And Another"))
         '       Sheet names go inside quotes, seperated by commas
        On Error GoTo ErrCatcher
        MyArr = Array("BBA", "BBV", "BBB")

        For j = 0 To UBound(MyArr)
            Set ws = Nothing

        On Error Resume Next
        Set ws = Worksheets(MyArr(j))
        On Error GoTo 0

        If Not ws Is Nothing Then
        'Your copying code goes here

         '       Paste sheets as values
         '       Remove External Links, Hperlinks and hard-code formulas
         '       Make sure A1 is selected on all sheets
        ws.Select
            ws.Cells.Copy
            ws.[A1].PasteSpecial Paste:=xlValues
            ws.Cells.Hyperlinks.Delete
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        End If
    Next
         '       Remove named ranges
        For Each nm In ActiveWorkbook.Names
        If nm.Visible Then nm.Delete
        Next nm
         
         '       Input box to name new file
        NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
         
         '       Save it with the NewName and in the same directory as original
        ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & Application.PathSeparator & "myFile.xlsm", FileFormat:=52
                
        Application.ScreenUpdating = True
    Exit Sub
     
ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub

Answer 1

概念上：

• 使用 For-Next 循环遍历工作簿中的所有工作表
• 将每个工作表名称与关键字列表进行比较
• 当工作表名称满足条件时，执行复制

此网站和其他网站上有许多代码示例，介绍如何循环工作簿中的所有工作表、如何在另一个字符串中查找字符串以及如何在工作簿之间复制工作表。