Как ускорить двойной цикл for с помощью if во внутреннем цикле в vba?

Question

Я написал этот код для поиска совпадения в столбце листа "q1" с элементами другого столбца в листе "Полная машина".Поскольку у меня есть 3000 строк для проверки в Complete Car и 1500 в q1 (внутренний цикл), есть ли какие-либо предложения о том, как написать это более эффективно?

Код указан ниже:

Sub PopulateData()

 Sheets("Q1").Visible = True

  Dim i As Integer
  Dim j As Integer

  For i = 4 To 3000

        For j = 2 To 1500


        If Worksheets("Complete Car").Cells(i, 2) = Worksheets("Q1").Cells(j, 21) Then

           Worksheets("Complete Car").Cells(i, 32) = Worksheets("Q1").Cells(j, 30)

           End If

        Next j

  Next i


  Sheets("Q1").Visible = False

Answer 1

Использовать массивы Variant

Sheets("Q1").Visible = True

With Worksheets("Complete Car")
    Dim vlue() As Variant
    vlue = .Range(.Cells(4, 2), .Cells(3000, 2))

    Dim out() As Variant
    ReDim out(1 To UBound(vlue, 1), 1 To 1)
End With

With Worksheets("Q1")
    Dim lkup() As Variant
    lkup = .Range(.Cells(2, 21), .Cells(1500, 30))
End With

Dim i As Long
For i = LBound(vlue, 1) To UBound(vlue, 1)
    Dim j As Long
    For j = LBound(lkup, 1) To UBound(lkup, 1)
        If vlue(i, 1) = lkup(j, 1) Then
            out(i, 1) = lkup(j, 10)
            Exit For
        End If
    Next j
Next i

Worksheets("Complete Car").Cells(4, 32).Resize(UBound(out, 1), UBound(out, 2)).Value = out

Sheets("Q1").Visible = False

Answer 2

Несмотря на то, что это вопрос для проверки кода, вот ответ с использованием словарей и массивов:

Option Explicit
Sub PopulateData()

    Dim arrCompleteCar As Variant, arrQ1 As Variant
    Dim i As Integer, j As Integer
    Dim Matches As New Scripting.Dictionary 'You will need the library Microsoft Scripting Runtime

    Application.ScreenUpdating = False 'speed up the code since excel won't show you what is happening

    'First of all, working on arrays always speeds up a lot the code because you are working on memory
    'instead of working with the sheets
    With ThisWorkbook
        arrCompleteCar = .Sheets("Complete_Car").UsedRange.Value 'this will throw your entire sheet into one 2D array
        arrQ1 = .Sheets("Q1").UsedRange.Value
    End With

    'Then we create a dictionary with the data on worksheet Q1
    For i = 2 To UBound(arrQ1) 'from row 2 to the last on Q1 (the highest)
        If arrQ1(i, 21) = vbNullString Then Exit For 'this is to avoid looping through blank cells
        If Not Matches.Exists(arrQ1(i, 21)) Then 'this is to avoid duplicates
            Matches.Add arrQ1(i, 21), arrQ1(i, 30) 'we add the matching value with the one to replace
        End If
    Next i

    arrQ1 = Nothing 'empty the Q1 array since it's useless now

    'Now we loop the Complete Car worksheet
    For i = 4 To UBound(arrCompleteCar)
        'in case we find a match, we replace the column 32 with the column 30 from Q1
        If Matches.Exists(arrCompleteCar(i, 2)) Then arrCompleteCar(i, 32) = Matches(arrCompleteCar(i, 2))
    Next i

    ThisWorkbook.Sheets("Complete_Car").UsedRange.Value = arrCompleteCar 'we paste the array back to the sheet

    arrCompleteCar = Nothing
    Matches.RemoveAll

    Application.ScreenUpdating = True 'return excel to normal

End Sub

Answer 3

Sub PopulateData()

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Worksheets("Complete Car").Range("AF4:AF3000").FormulaR1C1 = "=VLOOKUP('Complete Car'!RC2,Q1!R2C21:R1500C30,10,FALSE)"

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

    ' Convert formulas to values
    With Worksheets("Complete Car").Range("AF4:AF3000")
        .Value = .Value
    End With

End Sub