如何用VBA的GetObject合并多Excel年级班级数据至主工作簿

我有6个对应不同年级的Excel工作簿，每个工作簿内包含各班的学生数据。需要将这些数据合并到一个主工作簿中，要求无需打开源工作簿，因此采用GetObject方法。主工作簿中有个名为class_location的工作表，B列记录了各班数据的目标粘贴位置。

学校共6个年级，每个年级的班级数量、各班学生人数都不一样。每个年级对应一个Excel文件，文件内的工作表就是对应班级的学生名单。需要把所有年级的学生数据整合到主工作簿的6个对应年级工作表中。

目前已经能通过VBA获取这6个文件，但无法将各班的数据区域复制粘贴到主工作簿对应年级的指定位置。用S_row变量获取数据最后一行（不确定是否高效），用GetObject设置target_grade对象时，复制Range步骤出错，后续粘贴也无法执行。以下是原代码：

Sub copy_class(P As String, F As String)

Dim target_grade As Workbook
Set target_grade = GetObject(P & F)  '用GetObject获取源工作簿

For i = 1 To target_grade.Sheets.Count
    Dim classrow As Integer
    Dim class_loc As String
    Dim class_name As String
    Dim S_row As Integer

    S_row = target_grade.Sheets(i).Range("E6").End(xlDown).Row '获取最后一行数据
    
    target_grade.Range("a2:e" & S_row).Copy   '此处出错
    
    class_name = target_grade.Sheets(i).Name
    classrow = Sheets("class_location").Range("A1:A61").Find(class_name, lookat:=xlWhole).Row
    class_loc = Sheets("class_location").Range("B" & CStr(classrow)) '获取目标粘贴位置
    Sheets("class_location").Range(class_loc).Select
    ActiveSheet.Paste

Next

target_grade.Close
Set target = Nothing

End Sub

原代码存在的问题 #

• 复制Range未指定工作表：target_grade.Range("a2:e" & S_row)没有关联到当前循环的具体源工作表，导致引用错误
• 获取最后一行逻辑缺陷：如果E6下方无数据，End(xlDown)会直接跳到工作表最后一行，引发无效引用
• 依赖Select/ActiveSheet易出错：VBA中依赖窗口激活状态的操作极易因操作环境变化失效
• 变量声明位置不合理：循环内重复声明变量会占用额外内存，且不符合编码规范
• 对象释放错误：最后Set target = Nothing中的变量名与实际对象target_grade不匹配，无法正确释放资源

修正后的代码 #

Sub copy_class(P As String, F As String)
    Dim target_grade As Workbook
    Dim ws_source As Worksheet
    Dim ws_loc As Worksheet
    Dim i As Integer
    Dim classrow As Integer
    Dim class_loc As String
    Dim class_name As String
    Dim S_row As Long '用Long避免行号超过Integer范围（Excel最大行号为1048576）
    Dim found_cell As Range
    Dim paste_target As Range
    
    '获取源工作簿对象
    Set target_grade = GetObject(P & F)
    '提前获取位置表对象，避免重复查找
    Set ws_loc = ThisWorkbook.Sheets("class_location")
    
    For i = 1 To target_grade.Sheets.Count
        Set ws_source = target_grade.Sheets(i)
        
        '可靠获取最后一行：从E列底部往上找第一个非空行
        S_row = ws_source.Cells(ws_source.Rows.Count, "E").End(xlUp).Row
        '确保有数据可复制（至少A2到E2存在数据）
        If S_row >= 2 Then
            '复制源工作表的目标数据区域
            ws_source.Range("A2:E" & S_row).Copy
            
            '查找班级对应的目标位置
            class_name = ws_source.Name
            Set found_cell = ws_loc.Range("A1:A61").Find(class_name, LookAt:=xlWhole)
            If Not found_cell Is Nothing Then '确保找到对应班级的配置
                class_loc = ws_loc.Range("B" & found_cell.Row).Value
                '拆分目标位置为工作表名和单元格地址（格式示例："Grade1!A10"）
                Dim target_ws_name As String, target_range_addr As String
                target_ws_name = Split(class_loc, "!")(0)
                target_range_addr = Split(class_loc, "!")(1)
                
                '获取目标粘贴的起始单元格
                Set paste_target = ThisWorkbook.Sheets(target_ws_name).Range(target_range_addr)
                '粘贴值和数字格式（如需保留全部格式可改用xlPasteAll）
                paste_target.PasteSpecial xlPasteValuesAndNumberFormats
                '如果不需要复制格式，可直接赋值（效率更高）：
                'paste_target.Resize(S_row - 1, 5).Value = ws_source.Range("A2:E" & S_row).Value
            End If
        End If
    Next i
    
    '关闭源工作簿，不保存修改
    target_grade.Close SaveChanges:=False
    '释放所有对象资源
    Set ws_source = Nothing
    Set ws_loc = Nothing
    Set target_grade = Nothing
End Sub

优化说明 #

1. 可靠获取最后一行：从E列底部向上查找，避免空行导致的无效引用
2. 直接操作对象：取消Select/ActiveSheet依赖，通过对象直接操作，稳定性大幅提升
3. 添加错误判断：增加数据存在性、班级配置存在性的检查，避免运行时错误
4. 变量类型优化：用Long存储行号，适配Excel大行数场景
5. 高效赋值选项：如果不需要复制格式，直接赋值单元格值比复制粘贴速度更快

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