请求修复：将两表格数据合并到同列（无新增行）的VBA代码

问题原因 #

原代码通过按列循环的方式分别粘贴2022和2023的数据，导致每一列都是"2022数据+2023数据"的堆叠结构，而非按整行形式将2023数据追加到2022数据之后，不符合预期需求。

修复后的代码 #

Sub CopyPasteData()
    Dim Sh2022 As Worksheet, Sh2023 As Worksheet, ShQuery As Worksheet
    Dim LastRow As Long
    Dim TargetCols As Variant
    Dim SourceRange2022 As Range, SourceRange2023 As Range
    Dim i As Integer
    
    ' 清空Query2除第一行外的数据
    With ActiveSheet.ListObjects("Query2").DataBodyRange
       If .Rows.Count > 1 Then .Offset(1).Resize(.Rows.Count - 1).Delete
    End With
    
    ' 绑定工作表对象
    Set Sh2022 = ThisWorkbook.Sheets("Year2022")
    Set Sh2023 = ThisWorkbook.Sheets("Year2023")
    Set ShQuery = ThisWorkbook.Sheets("Data Table")

    ' 指定需要复制的列名
    TargetCols = Array("Customer Name", "Activity Type", "timeInterval.duration", "Description", "Platform", "Start Date")
    
    ' 构建2022表的目标列数据范围（整行结构）
    Set SourceRange2022 = Sh2022.ListObjects("Table2").ListColumns(TargetCols(0)).DataBodyRange
    For i = 1 To UBound(TargetCols)
        Set SourceRange2022 = Union(SourceRange2022, Sh2022.ListObjects("Table2").ListColumns(TargetCols(i)).DataBodyRange)
    Next i
    
    ' 构建2023表的目标列数据范围（整行结构）
    Set SourceRange2023 = Sh2023.ListObjects("Table3").ListColumns(TargetCols(0)).DataBodyRange
    For i = 1 To UBound(TargetCols)
        Set SourceRange2023 = Union(SourceRange2023, Sh2023.ListObjects("Table3").ListColumns(TargetCols(i)).DataBodyRange)
    Next i
    
    ' 复制2022数据到目标表起始位置
    LastRow = ShQuery.Cells(ShQuery.Rows.Count, 1).End(xlUp).Row + 1
    SourceRange2022.Copy
    ShQuery.Cells(LastRow, 1).PasteSpecial xlPasteValues
    
    ' 复制2023数据追加到目标表最后一行之后
    LastRow = ShQuery.Cells(ShQuery.Rows.Count, 1).End(xlUp).Row + 1
    SourceRange2023.Copy
    ShQuery.Cells(LastRow, 1).PasteSpecial xlPasteValues

    Application.CutCopyMode = False
End Sub

关键修改点 #

• 取消按列循环的粘贴逻辑，改为先构建包含所有指定列的整行数据范围
• 先将2022的整表指定列数据复制到目标表，再将2023的整表指定列数据追加到目标表最后一行，保证数据按行连续排列
• 使用Union方法合并多列数据范围，确保复制的是完整的行结构

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