Search code examples
excelvbaslowdown

Copy data against matching fields in another sheet

enter image description here enter image description here I am trying to copy data from the display sheet to relevant consumer # in bills sheet having (176000) rows, following code I found is working but it's very slow, around takes 5 minutes to execute one entry.

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

Display sheet: Display

Bills sheet: Bills

Solution

  • Try the next code, please. It should be very fast. It is only necessary to set the rows where the ranges will be copied (firstRow, lastRow) and take care to have the (consecutive) rows where the processing result to be pasted, in column 20. In fact, it would be enough to only write the first row:

    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