比较两个工作簿中的列，若存在相同的值则粘贴

Question

下面你可以看到我用来比较两个工作簿的代码，如果在第71列的工作簿1和工作簿2中发现相同的值，那么工作簿1中第30-35列之间的数据应该被放入工作簿2中的第30-35行。否则什么也不做。

目前，该代码在运行时部分正常工作，但在满足条件时，它主要从错误的行中获取值。我一直找不到原因。我希望你能提出可能导致这个问题的建议。

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LastRow1 As Long, LastRow2 As Long
Dim arr1 As Variant, arr2 As Variant, arr3 As Variant
Dim i As Long, j As Long
Dim lRow3 As Long
Dim lRow4 As Long

Set wb1 = Workbooks.Open("file1")
Set wb2 = Workbooks.Open("file2")
Set ws1 = wb1.Sheets(1)
Set ws2 = wb2.Sheets(1)
wb1.Activate
ws1.Select 
Range("BO7").NumberFormat = "@"
Range("BP7").NumberFormat = "@"
lRow3 = Range("BO" & Rows.count).End(xlUp).Row
For i = 7 To lRow3
    Cells(i, 71).NumberFormat = "@"
    Cells(i, 71) = Cells(i, 67) & Cells(i, 68)
Next i
wb2.Activate
ws2.Select
Range("BO7").NumberFormat = "@"
Range("BP7").NumberFormat = "@"
lRow4 = Range("BO" & Rows.count).End(xlUp).Row
For i = 7 To lRow4
    Cells(i, 71).NumberFormat = "@"
    Cells(i, 71) = Cells(i, 67) & Cells(i, 68)
Next i
ws1.Activate
Range("BS6").Value = "Reference"
ws2.Activate
Range("BS6").Value = "Reference"
 
LastRow1 = ws1.Cells(Rows.count, "A").End(xlUp).Row
LastRow2 = ws2.Cells(Rows.count, "A").End(xlUp).Row
ws1.Activate
arr1 = ws1.Range("A6:BS" & LastRow1)
arr2 = ws2.Range("A6:BS" & LastRow2)
For i = 7 To UBound(arr1)
    For j = 7 To UBound(arr2)
        If arr1(i, 71) = arr2(j, 71) Then
            
            arr2(j, 30) = arr1(i, 30)
            arr2(j, 31) = arr1(i, 31)
            arr2(j, 32) = arr1(i, 32)
            arr2(j, 33) = arr1(i, 33)
            arr2(j, 34) = arr1(i, 34)
            arr2(j, 35) = arr1(i, 35)
        End If
    Next j
Next i
ReDim arr3(6 To UBound(arr2), 1 To 6)
For i = 6 To UBound(arr2)
    arr3(i, 1) = arr2(i, 30)
    arr3(i, 2) = arr2(i, 31)
    arr3(i, 3) = arr2(i, 32)
    arr3(i, 4) = arr2(i, 33)
    arr3(i, 5) = arr2(i, 34)
    arr3(i, 6) = arr2(i, 35)
Next i
ws2.Range("AD7:AI" & LastRow2) = arr3

Answer 1

请尝试下一个更新的代码。这是基于我认为你干了什么。上一次迭代是不必要的，但我试着让代码保持原样。我的意思是，arr3可以在上一次中加载。除此之外，激活、选择只会消耗Excel资源，不会带来任何好处：

Sub copyFromTwoWorkbooks()
 Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet
 Dim LastRow1 As Long, LastRow2 As Long, arr1 As Variant, arr2 As Variant, arr3 As Variant
 Dim i As Long, j As Long, lRow3 As Long, lRow4 As Long

Set wb1 = Workbooks.Open("file1")
Set wb2 = Workbooks.Open("file2")
Set ws1 = wb1.Sheets(1): Set ws2 = wb2.Sheets(1)
ws1.Range("BO7").NumberFormat = "@": ws1.Range("BP7").NumberFormat = "@"
lRow3 = ws1.Range("BO" & ws1.rows.Count).End(xlUp).row
ws1.Range("BS7:BS" & lRow3).NumberFormat = "@"
For i = 7 To lRow3
    ws1.cells(i, 71) = ws1.cells(i, 67).Value & ws1.cells(i, 68).Value
Next i
ws2.Range("BO7").NumberFormat = "@": ws2.Range("BP7").NumberFormat = "@"
lRow4 = ws2.Range("BO" & ws2.rows.Count).End(xlUp).row
ws2.Range("BS7:BS" & lRow4).NumberFormat = "@"
For i = 7 To lRow4
    ws2.cells(i, 71) = ws2.cells(i, 67) & ws2.cells(i, 68)
Next i
ws1.Range("BS6").Value = "Reference": ws2.Range("BS6").Value = "Reference"
LastRow1 = ws1.cells(rows.Count, "A").End(xlUp).row
LastRow2 = ws2.cells(rows.Count, "A").End(xlUp).row
arr1 = ws1.Range("A6:BS" & LastRow1).Value
arr2 = ws2.Range("A6:BS" & LastRow2).Value
For i = 1 To UBound(arr1)
    For j = 1 To UBound(arr2)
        If arr1(i, 71) = arr2(j, 71) Then
            arr2(j, 30) = arr1(i, 30)
            arr2(j, 31) = arr1(i, 31)
            arr2(j, 32) = arr1(i, 32)
            arr2(j, 33) = arr1(i, 33)
            arr2(j, 34) = arr1(i, 34)
            arr2(j, 35) = arr1(i, 35)
            Exit For 'exiting the loop after finding a match
        End If
    Next j
Next i
ReDim arr3(1 To UBound(arr2), 1 To 6)
For i = 1 To UBound(arr2)
    arr3(i, 1) = arr2(i, 30)
    arr3(i, 2) = arr2(i, 31)
    arr3(i, 3) = arr2(i, 32)
    arr3(i, 4) = arr2(i, 33)
    arr3(i, 5) = arr2(i, 34)
    arr3(i, 6) = arr2(i, 35)
Next i
ws2.Range("AD7").Resize(UBound(arr3), UBound(arr3, 2)).Value = arr3
End Sub