Excel多工作表按组导出VBA代码报错求助（含需求及代码）

需求说明 #

现有工作簿包含以下工作表：ATP610、ATP610 Power、ATP620、ATP620 Power、ATP648、ATP648 Power、ATP648 KWTP、ATP648 SW，需按以下规则导出为新工作簿：

• 组1：将ATP610、ATP610 Power导出至名为ATP610的新工作簿，工作表重命名为「ATP610 WP&B」（复制范围D3:AU197）、「ATP610 Electricity Profile」（复制范围D3:Q29）
• 组2：将ATP620、ATP620 Power导出至名为ATP620的新工作簿，工作表重命名为「ATP620 WP&B」、「ATP620 Electricity Profile」
• 组3：将ATP648、ATP648 Power、ATP648 KWTP、ATP648 SW导出至名为ATP648的新工作簿，工作表保留对应指定名称
  要求新工作簿仅保留值与格式，无公式/链接，同时生成Excel和PDF文件。

原代码错误分析 #

原代码运行时报错Run-time error '424': Object required，且仅完成第一个工作表复制，问题点如下：

1. 对象引用未定义：子过程ExportData中使用ws.Name，但ws是主过程的局部变量，子过程无法访问，应改用参数SourceWorksheet.Name
2. 工作簿创建逻辑错误：每次调用ExportData都会新建一个工作簿，无法实现多个工作表合并到同一个新工作簿的需求
3. 行高设置错误：循环中始终设置tws.Rows(1)的行高，应改为tws.Rows(r)对应行的行高
4. PDF导出路径错误：直接使用tBaseName作为文件名，未关联实际保存路径，导致保存位置不可控
5. 字符串拼接语法错误：MsgBox中的错误信息拼接存在引号语法错误

修正后的完整VBA代码 #

Sub ExportAllGroups()
    Dim sourceWB As Workbook
    Set sourceWB = ThisWorkbook
    
    ' 处理组1：ATP610系列
    ExportGroup sourceWB, "ATP610", _
        Array("ATP610", "D3:AU197", "ATP610 WP&B"), _
        Array("ATP610 Power", "D3:Q29", "ATP610 Electricity Profile")
    
    ' 处理组2：ATP620系列
    ExportGroup sourceWB, "ATP620", _
        Array("ATP620", "", "ATP620 WP&B"), _
        Array("ATP620 Power", "", "ATP620 Electricity Profile")
    
    ' 处理组3：ATP648系列
    ExportGroup sourceWB, "ATP648", _
        Array("ATP648", "", "ATP648"), _
        Array("ATP648 Power", "", "ATP648 Power"), _
        Array("ATP648 KWTP", "", "ATP648 KWTP"), _
        Array("ATP648 SW", "", "ATP648 SW")
    
    MsgBox "所有分组导出完成！", vbInformation, "导出完成"
End Sub

' 导出一组工作表到同一个新工作簿
Sub ExportGroup(ByVal sourceWB As Workbook, ByVal targetWBName As String, ParamArray sheetInfos() As Variant)
    Const PROC_TITLE As String = "导出分组数据"
    Dim targetWB As Workbook
    Dim targetWS As Worksheet
    Dim sourceWS As Worksheet
    Dim sourceRange As Range
    Dim savePath As Variant
    Dim pdfPath As String
    Dim i As Integer
    
    ' 创建新工作簿并删除默认空白表
    Set targetWB = Application.Workbooks.Add(xlWBATWorksheet)
    Application.DisplayAlerts = False
    targetWB.Sheets(1).Delete
    Application.DisplayAlerts = True
    
    ' 遍历当前组的每个工作表信息
    For i = LBound(sheetInfos) To UBound(sheetInfos)
        Dim sheetInfo As Variant
        sheetInfo = sheetInfos(i)
        
        ' 引用源工作表
        On Error Resume Next
        Set sourceWS = sourceWB.Sheets(sheetInfo(0))
        On Error GoTo 0
        If sourceWS Is Nothing Then
            MsgBox "未找到工作表：" & sheetInfo(0), vbExclamation, PROC_TITLE
            targetWB.Close SaveChanges:=False
            Exit Sub
        End If
        
        ' 确定复制范围：指定范围优先，否则用已使用区域
        If sheetInfo(1) <> "" Then
            Set sourceRange = sourceWS.Range(sheetInfo(1))
        Else
            Set sourceRange = sourceWS.UsedRange
        End If
        
        ' 在目标工作簿新建工作表并命名
        Set targetWS = targetWB.Sheets.Add(After:=targetWB.Sheets(targetWB.Sheets.Count))
        targetWS.Name = sheetInfo(2)
        
        ' 复制值、格式、列宽
        sourceRange.Copy
        With targetWS.Range("A1")
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
            .PasteSpecial Paste:=xlPasteColumnWidths
        End With
        
        ' 匹配源表行高
        Dim r As Long
        r = 0
        For Each cell In sourceRange.Columns(1).Cells
            r = r + 1
            targetWS.Rows(r).RowHeight = cell.RowHeight
        Next cell
        
        ' 释放对象引用
        Set sourceWS = Nothing
        Set sourceRange = Nothing
        Set targetWS = Nothing
    Next i
    
    ' 获取Excel保存路径
    savePath = Application.GetSaveAsFilename( _
        InitialFileName:=targetWBName, _
        FileFilter:="Excel Workbooks (*.xlsx),*.xlsx")
    
    If VarType(savePath) = vbBoolean Then
        MsgBox "保存操作已取消", vbExclamation, PROC_TITLE
        targetWB.Close SaveChanges:=False
        Application.CutCopyMode = False
        Exit Sub
    End If
    
    ' 保存Excel文件
    Dim errNum As Long
    Dim errDesc As String
    Application.DisplayAlerts = False
    On Error Resume Next
        targetWB.SaveAs Filename:=savePath
        errNum = Err.Number
        errDesc = Err.Description
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    If errNum <> 0 Then
        MsgBox "保存Excel文件出错：" & vbLf & "错误代码：" & errNum & vbLf & "描述：" & errDesc, vbCritical, PROC_TITLE
        targetWB.Close SaveChanges:=False
        Exit Sub
    End If
    
    ' 导出PDF：替换Excel路径后缀为pdf
    pdfPath = Left(savePath, InStrRev(savePath, ".")) & "pdf"
    targetWB.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
    
    ' 关闭目标工作簿
    targetWB.Close SaveChanges:=False
    Application.CutCopyMode = False
End Sub

使用说明 #

1. 打开目标工作簿，按Alt+F11打开VBA编辑器
2. 插入新模块，粘贴上述代码
3. 运行ExportAllGroups宏，按提示选择保存路径即可完成所有分组导出
4. 如需调整某工作表的复制范围，在ExportAllGroups的对应数组中修改第二个参数（将""替换为具体单元格区域字符串）

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