如何修改Excel VBA宏实现多工作表批量复制粘贴至新工作簿

原代码仅支持单个工作表的指定区域复制导出，要实现批量处理多工作表，核心是通过数组定义目标工作表列表，并循环遍历每个工作表完成复制粘贴操作，同时调整导出逻辑适配多表场景。以下是修改后的完整代码及关键说明：

Sub SaveMultipleSheetsData()
    ' 声明对象变量
    Dim sourceWorkbook As Workbook
    Dim targetWorkbook As Workbook
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim cellRange As Range
    
    ' 声明其他变量
    Dim targetWorkbookName As String
    Dim baseFileName As String
    Dim pdfFileName As String
    Dim sourceSheetNames As Variant
    Dim sourceRangeAddress As String
    Dim targetRangeAddress As String
    Dim rowCounter As Long
    Dim sheetName As Variant
    
    ' <<<< 自定义配置区 >>>>
    sourceSheetNames = Array("ATP620", "Sheet2", "Sheet3") ' 要处理的工作表名称列表，按需添加/修改
    sourceRangeAddress = "D3:AU197" ' 每个工作表要复制的区域地址
    targetRangeAddress = "A1" ' 目标工作簿中粘贴的起始单元格
    baseFileName = "批量导出数据_2023" ' 基础文件名
    
    ' 引用源工作簿
    Set sourceWorkbook = ThisWorkbook
    ' 创建新的目标工作簿
    Set targetWorkbook = Application.Workbooks.Add
    
    ' 关闭屏幕刷新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 循环处理每个指定的工作表
    For Each sheetName In sourceSheetNames
        ' 检查源工作表是否存在
        On Error Resume Next
        Set sourceSheet = sourceWorkbook.Sheets(sheetName)
        On Error GoTo 0
        
        If Not sourceSheet Is Nothing Then
            ' 在目标工作簿新建工作表，命名为源表名称
            Set targetSheet = targetWorkbook.Sheets.Add(After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count))
            targetSheet.Name = sheetName
            
            ' 引用源区域
            Set sourceRange = sourceSheet.Range(sourceRangeAddress)
            ' 复制源区域
            sourceRange.Copy
            
            ' 粘贴值、格式、列宽
            targetSheet.Range(targetRangeAddress).PasteSpecial Paste:=xlPasteValues
            targetSheet.Range(targetRangeAddress).PasteSpecial Paste:=xlPasteFormats
            targetSheet.Range(targetRangeAddress).PasteSpecial Paste:=xlPasteColumnWidths
            
            ' 调整行高
            Set targetRange = targetSheet.Range(targetRangeAddress).Resize(sourceRange.Rows.Count, sourceRange.Columns.Count)
            rowCounter = 0
            For Each cellRange In sourceRange.Columns(1).Cells
                rowCounter = rowCounter + 1
                targetRange.Rows(rowCounter).RowHeight = cellRange.RowHeight
            Next cellRange
            
            ' --------------------------
            ' 可选：每个工作表单独导出PDF
            ' pdfFileName = Replace(baseFileName, ".xlsx", "") & "_" & sheetName & ".pdf"
            ' sourceRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFileName, _
            '                                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            '                                IgnorePrintAreas:=False, OpenAfterPublish:=False
            ' --------------------------
        Else
            MsgBox "工作表 '" & sheetName & "' 不存在，已跳过该表", vbExclamation
        End If
    Next sheetName
    
    ' 清除剪贴板状态
    Application.CutCopyMode = False
    
    ' 获取保存路径及文件名
    targetWorkbookName = Application.GetSaveAsFilename(InitialFileName:=baseFileName, _
                                                      fileFilter:="Excel Workbooks (*.xlsx),*.xlsx")
    
    If targetWorkbookName = vbNullString Then
        MsgBox "保存操作已取消"
        targetWorkbook.Close SaveChanges:=False
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 保存目标工作簿
    targetWorkbook.SaveAs Filename:=targetWorkbookName
    
    ' --------------------------
    ' 可选：将整个目标工作簿导出为单个PDF
    pdfFileName = Replace(targetWorkbookName, ".xlsx", ".pdf")
    targetWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfFileName, _
                                       Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                                       IgnorePrintAreas:=False, OpenAfterPublish:=True
    ' --------------------------
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "所有工作表处理完成，已保存Excel文件及PDF文件", vbInformation
End Sub

关键修改说明 #

1. 多工作表列表定义：用sourceSheetNames = Array("表1", "表2")指定要处理的所有工作表，支持任意数量的表
2. 循环遍历处理：通过For Each sheetName In sourceSheetNames逐个处理每个工作表，自动在目标工作簿新建对应名称的工作表
3. 工作表存在性检查：添加错误处理，跳过不存在的工作表并提示，避免宏报错中断
4. PDF导出选项：
   • 若需要每个工作表单独导出PDF，取消注释循环内的PDF导出代码
   • 若需要将所有表合并为一个PDF，保留循环外的目标工作簿导出代码
5. 性能优化：添加Application.ScreenUpdating = False关闭屏幕刷新，大幅提升批量处理的运行速度

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