根据另一个工作表中的匹配字段复制数据

如何解决根据另一个工作表中的匹配字段复制数据

我正在尝试将数据从显示表复制到具有（176000）行的票据表中的相关消费者＃，下面的代码我发现可以正常运行，但是非常慢，大约需要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,25) = Sheets("display").Cells(i,7)
           Sheets("Bills").Cells(Cells(i,26) = Sheets("display").Cells(i,9)
           Sheets("Bills").Cells(Cells(i,27) = Sheets("display").Cells(i,11)
        End If
    Next
End Sub

显示页：

帐单：

解决方法

请尝试下一个代码。应该很快。只需设置要复制范围的行（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),7)).value
 arr26 = shD.Range(shD.cells(firstRow,9),9)).value
 arr27 = shD.Range(shD.cells(firstRow,11),11)).value
 arrRows = shD.Range(shD.cells(firstRow,20),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,25).value = arr25(i,1)
    If arr26(i,26).value = arr26(i,1)
    If arr27(i,27).value = arr27(i,1)
  Next i
  Application.Calculation = xlCalculationAutomatic
  
 shB.Activate: shB.cells(pasteRow,24).Select
 MsgBox "Ready..."
End Sub