求VBA解决方案：按工作表名称选择性复制保存工作表

问题背景 #

我所在机构每周发布一份Excel格式的周报，包含60多个工作表，每个表以活动缩写命名。我仅需要其中特定的工作表，目前手动查找并复制到新工作簿。现有VBA方案需在数组中预定义工作表名称，但我的场景中若某项活动未开展，对应活动代码的工作表不会出现在工作簿中，因此这类方案不适用。

所需功能 #

• 根据工作表名称中的特定活动代码识别目标工作表（我有完整的代码列表）
• 跳过工作簿中不存在的工作表名称
• 将识别到的工作表复制并保存到新工作簿
• 允许用户选择新工作簿的保存路径，而非自动保存到原工作簿所在路径

我是VBA新手，尝试合并网上找到的多个代码修改但未成功。测试时用了三个工作表名称（实际运行会提取20个），其中"BBA"和"BBB"存在，"BBV"不存在，希望代码写法更简洁。

优化后的VBA代码 #

Sub CopyTargetSheetsToNewWorkbook()
    Dim targetSheetNames As Variant
    Dim ws As Worksheet
    Dim newWB As Workbook
    Dim savePath As Variant
    Dim i As Long
    
    ' 确认是否执行操作
    If MsgBox("是否要将指定工作表复制到新工作簿？复制后工作表将仅保留值，移除超链接", vbYesNo, "确认操作") = vbNo Then Exit Sub
    
    ' 定义需要提取的活动代码（工作表名称）列表
    targetSheetNames = Array("BBA", "BBV", "BBB") ' 实际使用时替换为你的完整代码列表
    
    Application.ScreenUpdating = False
    Set newWB = Workbooks.Add ' 创建新工作簿
    
    ' 遍历目标列表，复制存在的工作表到新工作簿
    For i = LBound(targetSheetNames) To UBound(targetSheetNames)
        Set ws = Nothing
        On Error Resume Next
        Set ws = ThisWorkbook.Worksheets(targetSheetNames(i))
        On Error GoTo 0
        
        If Not ws Is Nothing Then
            ' 复制工作表到新工作簿（放在最后）
            ws.Copy After:=newWB.Sheets(newWB.Sheets.Count)
            ' 处理复制后的工作表：转为值，删除超链接
            With newWB.Sheets(targetSheetNames(i))
                .Cells.Copy
                .Range("A1").PasteSpecial Paste:=xlValues
                .Cells.Hyperlinks.Delete
                Application.CutCopyMode = False
                .Range("A1").Select
            End With
        End If
    Next i
    
    ' 删除新工作簿默认的空白工作表
    Application.DisplayAlerts = False
    For Each ws In newWB.Sheets
        If ws.Name = "Sheet1" Or ws.Name = "Sheet2" Or ws.Name = "Sheet3" Then
            ws.Delete
        End If
    Next ws
    Application.DisplayAlerts = True
    
    ' 让用户选择保存路径和文件名
    savePath = Application.GetSaveAsFilename( _
        FileFilter:="Excel Macro-Enabled Workbook (*.xlsm), *.xlsm, Excel Workbook (*.xlsx), *.xlsx", _
        Title:="选择新工作簿的保存位置")
    
    ' 如果用户未取消保存
    If savePath <> False Then
        newWB.SaveAs Filename:=savePath
        MsgBox "新工作簿已保存：" & savePath, vbInformation
    Else
        MsgBox "保存已取消", vbExclamation
        newWB.Close SaveChanges:=False
    End If
    
    Application.ScreenUpdating = True
End Sub

代码说明 #

1. 目标列表定义：在targetSheetNames数组中填入你需要的活动代码（工作表名称），代码会自动跳过不存在的表
2. 新工作簿创建：直接创建空白新工作簿，避免修改原周报文件
3. 工作表处理：复制后的工作表会转为值并删除超链接，保留数据但去除公式和链接
4. 保存路径选择：通过GetSaveAsFilename让用户自由选择保存位置和文件名，支持xlsm/xlsx格式
5. 错误处理：通过On Error Resume Next判断工作表是否存在，不会因缺失表而报错

内容的提问来源于stack exchange，提问作者Biolife83