如何修改VBA代码实现对比工作簿并复制新增数据整行

原代码仅能复制新增数据的A列值，需修改为复制新增数据的整行，以下是调整后的代码及说明：

修改后的完整代码 #

Sub AddMissingItems()
    Dim Dic As Object
    Dim Arr() As Variant, outArr() As Variant
    Dim i As Long, k As Long, iRow As Long
    Dim srcColCount As Long, destColCount As Long
    
    Set Dic = CreateObject("Scripting.dictionary")
    ' 读取目标表（Sheet1）的A列数据到字典，用于判断是否已存在
    With Sheets("Sheet1")
        destColCount = .Cells(1, Columns.Count).End(xlToLeft).Column
        Arr = .Range("A1:A" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
        For i = 1 To UBound(Arr, 1)
            If Not Dic.exists(Arr(i, 1)) Then
                Dic.Add Arr(i, 1), ""
            End If
        Next
    End With
    
    ' 读取源文件（ExtractFile的Sheet1）的整行数据，筛选新增项
    With Workbooks("ExtractFile").Worksheets("Sheet1")
        srcColCount = .Cells(1, Columns.Count).End(xlToLeft).Column
        Arr = .Range("A1:" & .Cells(1, srcColCount).Address(False, False) & .Range("A" & .Rows.Count).End(xlUp).Row).Value
        ' 初始化输出数组，列数取源文件的列数
        ReDim outArr(1 To UBound(Arr), 1 To srcColCount)
        
        For i = 1 To UBound(Arr)
            If Not Dic.exists(Arr(i, 1)) Then
                k = k + 1
                ' 复制整行数据到输出数组
                For col = 1 To srcColCount
                    outArr(k, col) = Arr(i, col)
                Next col
            End If
        Next
    End With
    
    ' 将新增数据写入目标表
    iRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
    If k <> 0 Then
        Sheets("Sheet1").Range("A" & iRow).Resize(k, destColCount).Value = outArr
        k = 0
    End If
End Sub

关键修改点 #

• 读取ExtractFile的Sheet1时，不再局限于A列，而是读取所有有效数据列的整行内容
• 调整输出数组outArr的列数为源文件的有效列数，确保能存储整行数据
• 新增列循环，将新增行的每一列数据都写入输出数组
• 写入目标表时，通过Resize(k, destColCount)指定粘贴的列数，保证整行数据正确写入

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