Question

找到以下代码，只将“新”数据从工作簿1复制到工作簿2。它完成它的设想，但仅限于两列A和B.我的数据一直延伸到ZQ的每一行。我试图为我的目的调整代码，但它超越了我。我感谢任何帮助。

Sub CompareArrays()

Dim arr1() As Variant, arr2() As Variant, arr3() As Variant
Dim i As Long, j As Long, k As Long, nextRow As Long
Dim wb1 As Workbook, wb2 As Workbook
Dim x As Boolean

Set wb1 = Workbooks("Workbook1.xlsm") 'Name of first workbook
Set wb2 = Workbooks("Workbook2.xlsx") 'Name of second workbook
arr1 = wb1.Sheets(1).Range("A2:B" & wb1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row).Value
arr2 = wb2.Sheets(1).Range("A2:B" & wb2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row).Value

For i = LBound(arr1) To UBound(arr1)
    x = True
    For j = LBound(arr2) To UBound(arr2)
        If arr1(i, 1) = arr2(j, 1) Then
            x = False
            Exit For
        End If
    Next j
    If x = True Then
        k = k + 1
        ReDim Preserve arr3(2, k)
        arr3(1, k - 1) = arr1(i, 2)
        arr3(0, k - 1) = arr1(i, 1)
    End If
Next i

With wb2.Sheets(1)
    nextRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
    .Range(.Cells(nextRow, 1), .Cells(nextRow + k, 2)) = Application.Transpose(arr3)
End With

End Sub

Answer 1

请尝试以下代码：

Sub CompareArrays()

Dim arr1() As Variant, arr2() As Variant, arr3() As Variant
Dim i As Long, j As Long, k As Long, nextRow As Long
Dim wb1 As Workbook, wb2 As Workbook
Dim x As Boolean

Set wb1 = Workbooks("Workbook1.xlsm") 'Name of first workbook
Set wb2 = Workbooks("Workbook2.xlsx") 'Name of second workbook
arr1 = wb1.Sheets(1).Range("A2:A" & wb1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row).Value
arr2 = wb2.Sheets(1).Range("A2:A" & wb2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row).Value
k = 1
For i = LBound(arr1) To UBound(arr1)
    x = True
    For j = LBound(arr2) To UBound(arr2)
        If arr1(i, 1) = arr2(j, 1) Then
            x = False
            Exit For
        End If
    Next j
    If x = True Then
        k = k + 1
        pos = Application.Match(arr1(i, 1), arr1, False) + 1 'get position in array
        nextRow = wb2.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
        wb2.Sheets(1).Rows(nextRow).EntireRow.Value = wb1.Sheets(1).Rows(pos).EntireRow.Value
    End If
Next i

End Sub

仅将新数据从一个工作簿复制到另一个工作簿

1 个答案: