根据另一个 sheet 中的匹配字段复制数据

Copy data against matching fields in another sheet

我正在尝试将数据从显示器 sheet 复制到具有 (176000) 行的账单 sheet 中的相关消费者,按照我发现的代码工作但它非常慢,执行一个条目大约需要 5 分钟.

Sub SAVERECOVERY()

    For i = 5 To 125
        If Cells(i, 20) > 0 Then
           Sheets("Bills").Cells(Cells(i, 20), 24) = Sheets("Display").Cells(i, 5)
           Sheets("Bills").Cells(Cells(i, 20), 25) = Sheets("Display").Cells(i, 7)
           Sheets("Bills").Cells(Cells(i, 20), 26) = Sheets("Display").Cells(i, 9)
           Sheets("Bills").Cells(Cells(i, 20), 27) = Sheets("Display").Cells(i, 11)
        End If
    Next
End Sub

显示sheet:

账单sheet:

请尝试下一个代码。它应该非常快。只需要设置要复制范围的行 (firstRow, lastRow) 并注意将要粘贴处理结果的(连续)行放在第 20 列中。在事实上,只写第一行就足够了:

Sub SAVERECOVERY()
 Dim firstRow As Long, lastRow As Long, shB As Worksheet, shD As Worksheet
 Dim arr24 As Variant, arr25 As Variant, arr26 As Variant, arr27 As Variant
 Dim pasteRow As Long, i As Long, arrRows As Variant
 
 Set shB = Sheets("Bills")
 Set shD = Sheets("Display")
 firstRow = 5: lastRow = 125: pasteRow = CLng(shD.cells(firstRow, 20))

 arr24 = shD.Range(shD.cells(firstRow, 5), shD.cells(lastRow, 5)).value
 arr25 = shD.Range(shD.cells(firstRow, 7), shD.cells(lastRow, 7)).value
 arr26 = shD.Range(shD.cells(firstRow, 9), shD.cells(lastRow, 9)).value
 arr27 = shD.Range(shD.cells(firstRow, 11), shD.cells(lastRow, 11)).value
 arrRows = shD.Range(shD.cells(firstRow, 20), shD.cells(lastRow, 20)).value
 
 Application.Calculation = xlCalculationManual
  For i = 1 To UBound(arrRows)
    If arr24(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 24).value = arr24(i, 1)
    If arr25(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 25).value = arr25(i, 1)
    If arr26(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 26).value = arr26(i, 1)
    If arr27(i, 1) <> "" Then shB.cells(CLng(arrRows(i, 1)), 27).value = arr27(i, 1)
  Next i
  Application.Calculation = xlCalculationAutomatic
  
 shB.Activate: shB.cells(pasteRow, 24).Select
 MsgBox "Ready..."
End Sub