如何将Excel多工作表指定范围数据批量复制到同一新工作簿

核心修改逻辑：

• 仅创建1次新工作簿作为统一汇总载体，避免遍历过程中重复生成新文件
• 循环遍历所有待处理工作表，无需逐表手动运行代码
• 每次粘贴前自动定位汇总表的首个空白行，避免数据覆盖
• 取消原有激活工作表的操作，通过对象直接引用执行操作，运行更稳定

修改后的可直接运行代码：

Sub CopyAllSheetsToSingleWorkbook()
    Dim sourceWb As Workbook
    Dim targetWb As Workbook
    Dim ws As Worksheet
    Dim copyRange As Range
    Dim nextRow As Long
    
    Set sourceWb = ThisWorkbook
    ' 仅创建1个汇总用新工作簿
    Set targetWb = Workbooks.Add
    
    ' 遍历源工作簿下所有工作表
    For Each ws In sourceWb.Worksheets
        ' 按需添加过滤规则，比如跳过名称为汇总的表、仅处理带月份关键词的表
        ' 示例：If InStr(ws.Name, "2022") > 0 Then
        
            ' 定义当前表要复制的范围，和原有代码的范围保持一致
            Set copyRange = ws.Range("C1:C66, G1:G66, H1:H66")
            ' 计算汇总表下一个可粘贴的空白行号
            nextRow = targetWb.Sheets(1).Cells(targetWb.Sheets(1).Rows.Count, "A").End(xlUp).Row + 1
            ' 首次粘贴时从第1行开始
            If nextRow = 2 And targetWb.Sheets(1).Range("A1").Value = "" Then nextRow = 1
            
            ' 执行复制粘贴
            copyRange.Copy
            targetWb.Sheets(1).Range("A" & nextRow).PasteSpecial Paste:=xlPasteAll
            
        ' End If ' 对应上面的过滤规则，不需要过滤可以删除相关判断行
    Next ws
    
    ' 清空剪贴板状态
    Application.CutCopyMode = False
End Sub

可选调整项：

• 如果不需要处理全部工作表，放开代码中注释的过滤逻辑，按自身需求修改表名匹配规则即可
• 如果仅需要提取单元格值、不需要保留原格式，将粘贴参数修改为Paste:=xlPasteValues
• 如果需要不同工作表的提取数据之间保留空行间隔，将nextRow的计算结果+1即可
• 如果需要给每段数据加上来源工作表名称作为标识，可以在粘贴前先在A列对应行写入ws.Name

内容的提问来源于stack exchange，提问作者Janek Novák