从多个工作表复制指定区域的VBA宏优化需求

问题修正方向 #

你当前的代码仅能处理单个固定名称的工作表，无法遍历目标文件中的所有工作表；同时粘贴时固定到指定区域，没有考虑主工作簿已有数据的追加需求（容易覆盖原有内容）。下面是优化后的代码，解决这两个核心问题。

改进后的完整代码 #

Sub GetJEData()
    Dim wsSource As Worksheet
    Dim wsMaster As Worksheet
    Dim filetoOpen As Variant
    Dim Openbook As Workbook
    Dim lastRowSource As Long
    Dim lastRowMaster As Long
    
    ' 指定主工作簿的目标工作表
    Set wsMaster = ThisWorkbook.Worksheets("Journal Entry")
    
    ' 关闭屏幕更新和警告提示，提升运行效率
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 弹出文件选择窗口，选择要导入的Excel文件
    filetoOpen = Application.GetOpenFilename( _
        Title:="选择要导入的Excel文件", _
        FileFilter:="Excel文件 (*.xls*), *.xls*")
    
    If filetoOpen <> False Then
        Set Openbook = Application.Workbooks.Open(filetoOpen)
        
        ' 遍历目标文件中的所有工作表
        For Each wsSource In Openbook.Worksheets
            ' 1. 源表C列（从C18开始）→ 主表E列，追加到最后一行
            lastRowSource = wsSource.Range("C" & wsSource.Rows.Count).End(xlUp).Row
            If lastRowSource >= 18 Then
                lastRowMaster = wsMaster.Range("E" & wsMaster.Rows.Count).End(xlUp).Row
                ' 如果主表E14以下无数据，从E14开始；否则从下一行追加
                lastRowMaster = IIf(lastRowMaster < 14, 14, lastRowMaster + 1)
                wsSource.Range("C18:C" & lastRowSource).Copy _
                    Destination:=wsMaster.Range("E" & lastRowMaster)
            End If
            
            ' 2. 源表H列 → 主表L列
            lastRowSource = wsSource.Range("H" & wsSource.Rows.Count).End(xlUp).Row
            If lastRowSource >= 18 Then
                lastRowMaster = wsMaster.Range("L" & wsMaster.Rows.Count).End(xlUp).Row
                lastRowMaster = IIf(lastRowMaster < 14, 14, lastRowMaster + 1)
                wsSource.Range("H18:H" & lastRowSource).Copy _
                    Destination:=wsMaster.Range("L" & lastRowMaster)
            End If
            
            ' 3. 源表K列 → 主表J列
            lastRowSource = wsSource.Range("K" & wsSource.Rows.Count).End(xlUp).Row
            If lastRowSource >= 18 Then
                lastRowMaster = wsMaster.Range("J" & wsMaster.Rows.Count).End(xlUp).Row
                lastRowMaster = IIf(lastRowMaster < 14, 14, lastRowMaster + 1)
                wsSource.Range("K18:K" & lastRowSource).Copy _
                    Destination:=wsMaster.Range("J" & lastRowMaster)
            End If
            
            ' 4. 源表S列 → 主表AB列
            lastRowSource = wsSource.Range("S" & wsSource.Rows.Count).End(xlUp).Row
            If lastRowSource >= 18 Then
                lastRowMaster = wsMaster.Range("AB" & wsMaster.Rows.Count).End(xlUp).Row
                lastRowMaster = IIf(lastRowMaster < 14, 14, lastRowMaster + 1)
                wsSource.Range("S18:S" & lastRowSource).Copy _
                    Destination:=wsMaster.Range("AB" & lastRowMaster)
            End If
            
            ' 5. 源表O列 → 主表Z列
            lastRowSource = wsSource.Range("O" & wsSource.Rows.Count).End(xlUp).Row
            If lastRowSource >= 18 Then
                lastRowMaster = wsMaster.Range("Z" & wsMaster.Rows.Count).End(xlUp).Row
                lastRowMaster = IIf(lastRowMaster < 14, 14, lastRowMaster + 1)
                wsSource.Range("O18:O" & lastRowSource).Copy _
                    Destination:=wsMaster.Range("Z" & lastRowMaster)
            End If
        Next wsSource
        
        ' 关闭源文件，不保存任何修改
        Openbook.Close SaveChanges:=False
    End If
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

关键功能说明 #

• 多工作表遍历：通过For Each wsSource In Openbook.Worksheets循环，自动处理目标文件中的每一个工作表，无需手动指定工作表名称
• 数据追加逻辑：每次复制前获取主表目标列的最后一行，确保新数据追加在已有数据下方，不会覆盖原有内容；同时兼容主表目标列无数据的情况，从指定行（14行）开始粘贴
• 安全防护：关闭屏幕更新和警告提示提升运行速度，操作完成后恢复默认设置；关闭源文件时不保存，避免误修改原始数据
• 空数据校验：判断源表起始行（18行）以下是否有数据，防止复制空区域导致的无效操作

使用注意事项 #

1. 确认主工作簿的目标工作表名称为Journal Entry，如果名称不同，修改代码中Set wsMaster = ThisWorkbook.Worksheets("Journal Entry")的工作表名称
2. 如果源文件中数据的起始行不是18行，批量替换代码中所有的18为实际起始行号
3. 运行宏前建议备份主工作簿和源文件，避免意外数据丢失

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