Excel VBA实现多工作表指定区域复制到单表及错误13修复

算力阿峰

2026-9-3

问题说明

需要实现多工作表指定区域数据汇总到主工作表的功能，具体规则：

每个待取数工作表的复制范围为C3单元格至C列最后一行有数据的单元格区域
第一个工作表的复制结果粘贴到主表B6单元格起始的列中，后续工作表的结果依次粘贴到主表C6、D6……直至J6单元格起始的对应列
原有代码在Set DatSh = Sheets(DatSh)行触发运行时错误'13'：类型不匹配，无法正常运行

错误原因

原有代码存在多处语法和逻辑问题，具体如下：

核心报错原因：DatSh变量未提前赋值就传入Sheets()方法作为参数，VBA无法识别参数类型，直接触发类型不匹配错误
逻辑冗余：已将所有数据源表存入数组DatShs但未做遍历，反而硬编码重复写9次复制粘贴逻辑，容易出现引用错误
范围写法错误：Lrow被定义为单元格对象而非行号数值，"C3" & Lrow、Range("TnD", Lrow)这类拼接方式无法生成有效单元格范围
引用语法错误：ActiveWorkbook.WkSh为非法写法，WkSh本身是已赋值的工作表对象，不需要通过工作簿对象二次引用
方法调用错误：VBA不支持无参数直接调用Range对象的.Paste方法，需要通过PasteSpecial指定粘贴类型，或直接通过对象赋值完成数据写入

修正后可运行代码

Sub 汇总多表C列数据()
    Dim mainSh As Worksheet
    Dim datSh As Worksheet
    Dim datShNames As Variant
    Dim lastRow As Long
    Dim targetCol As Long
    Dim i As Long
    
    ' 绑定主工作表为当前激活工作表
    Set mainSh = ActiveSheet
    ' 按粘贴顺序排列所有待取数的工作表名称
    datShNames = Array("E0303_0", "E0304", "E0305", "E0306", "E0307", "E0308", "E0309", "E0310", "E0311_0")
    ' 第一个粘贴位置为主表B列（列号2）第6行
    targetCol = 2
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 遍历所有数据源工作表完成复制粘贴
    For i = LBound(datShNames) To UBound(datShNames)
        Set datSh = ThisWorkbook.Worksheets(datShNames(i))
        ' 计算当前表C列最后一个有数据的行号
        lastRow = datSh.Cells(datSh.Rows.Count, "C").End(xlUp).Row
        
        ' 仅当C3及以下有有效数据时执行复制
        If lastRow >= 3 Then
            datSh.Range("C3:C" & lastRow).Copy
            mainSh.Cells(6, targetCol).PasteSpecial Paste:=xlPasteAll
        End If
        
        ' 目标列右移一位，对应下一个工作表的粘贴位置
        targetCol = targetCol + 1
    Next i
    
    ' 恢复默认设置
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "数据汇总完成"
End Sub

代码说明

采用循环遍历方式处理所有工作表，不需要重复编写复制粘贴逻辑，后续增减数据源只需要修改datShNames数组内的表名即可
每个工作表单独计算自身C列的最后数据行，避免共用行号导致的取数范围错误
自动跳过C列无有效数据的空表，不会触发运行时错误
粘贴列自动从B列开始逐列后移，完全匹配B6到J6的粘贴位置要求

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