Double FOR loop takes a while to complete

Question

I need to compare 2 cells in different sheets and get a value if there's a match. I currently have this piece of code, it each cell in column B is checked to each cell in column A and if there's a match the corresponding cell in column C is copied. So far so good, the problem is, it takes a long time to do so. I only have 750 records in column B and 4000 in column A.

Are there ways to optimize the code so it runs faster?

For i = 2 To LastRow
    For j = 2 To LastRowJ
        If Sheets("tempsheet").Range("B" & i).Value = Sheets("tempsheet").Range("A" & j).Value Then
            Range("Q" & i).Value = Sheets("tempsheet").Range("C" & j).Value
        End If
    Next j
Next i

Answer 1

Here are 6 measurements:

1. copyValsCell1():    90.78125 sec (posted code)
2. copyValsCell2():    53.27343 sec (ws object)
3. copyValsCell3():    52.67187 sec (With statement, and screen off)

4. copyValsArr():       0.60937 sec (Array - no restrictions)

5. copyValsDictCell():  0.07812 sec (Dictionary with Range - unique values only)
6. copyValsDictArr():   0.03125 sec (Dictionary with Array - unique values only)

In my test file I had all values on the same sheet (lr = 4000: lrj = 750)

.

1. Initial code - Duration copyValsCell1(): 90.78125 sec

---

2. ws object

---

Set ws = Sheets("tempsheet")
For i = 2 To lr                             'Duration copyValsCell2(): 53.2734375 sec
    For j = 2 To lrj
        If ws.Range("B" & i).Value = ws.Range("A" & j).Value Then
            ws.Range("Q" & i).Value = ws.Range("C" & j).Value
        End If
    Next
Next

---

3. With statement, and screen off

---

Set ws = Sheets("tempsheet")
Application.ScreenUpdating = False
For i = 2 To lr                             'Duration copyValsCell3(): 52.671875 sec
    For j = 2 To lrj
        With ws
            If .Range("B" & i).Value2 = .Range("A" & j).Value2 Then
                .Range("Q" & i).Value2 = .Range("C" & j).Value2
            End If
        End With
    Next
Next
Application.ScreenUpdating = True

---

4. Array

---

Dim v As Variant
v = Sheets("tempsheet").Range("A1:Q4000")
For i = 2 To lr                             'Duration copyValsArr(): 0.609375 sec
    For j = 2 To lrj
        If v(i, 2) = v(j, 1) Then v(i, 17) = v(j, 3)
    Next
Next
Sheets("tempsheet").Range("A1:Q4000") = v

---

5. Dictionary with Range (requires reference to Microsoft Scripting Runtime library)

---

Set d = New Dictionary: Set ws = Sheets("tempsheet")
For i = 2 To lrj                            'Duration copyValsDictCell(): 0.078125 sec
    d(ws.Range("A" & i).Value2) = i
Next
For i = 2 To lr
    If d.Exists(ws.Range("B" & i).Value) Then
        ws.Range("Q" & i).Value = ws.Range("C" & d(ws.Range("B" & i).Value)).Value
    End If
Next

---

6. Dictionary with Array (requires reference to Microsoft Scripting Runtime library)

---

Dim v As Variant
v = Sheets("tempsheet").Range("A1:Q4000")
Set d = New Dictionary                      'Duration copyValsDictArr(): 0.03125 sec
For i = 2 To lrj
    d(v(i, 1)) = i
Next
For i = 2 To lr
    If d.Exists(v(i, 2)) Then v(i, 17) = v(d(v(i, 2)), 3)
Next
Sheets("tempsheet").Range("A1:Q4000") = v

---

Answer 2

Try this:

For i = 2 To LastRow
    Set match_check = Sheets("tempsheet").Range("A:A").Find(Sheets("tempsheet").Range("B" & i), Lookat:=xlWhole)
    If Not match_check Is Nothing Then Range("Q" & i) = match_check.Offset(0,2)
Next i

Find returns a Range object of the first found match in the column and Nothing if no match is found. I didn't check the run time but it should be faster than the double for loop.

Answer 3

You could use a dictionary keyed to the values in Column A -- assuming that these values are all distinct (otherwise your code itself doesn't quite make sense. Include a reference to Microsoft Scripting Runtime (via Tools/References in the VBA editor). The following code should be over 100 times as fast as what you currently have:

Sub test()
    Dim LastRow As Long, LastRowJ As Long
    Dim i As Long, j As Long
    Dim AVals As New Dictionary

    LastRow = Sheets("tempsheet").Cells(Rows.Count, "B").End(xlUp).Row()
    LastRowJ = Sheets("tempsheet").Cells(Rows.Count, "A").End(xlUp).Row()
    For j = 2 To LastRowJ
        AVals.Add Sheets("tempsheet").Range("A" & j).Value, j
    Next j
    For i = 2 To LastRow
        If AVals.Exists(Sheets("tempsheet").Range("B" & i).Value) Then
            j = AVals(Sheets("tempsheet").Range("B" & i).Value)
            Range("Q" & i).Value = Sheets("tempsheet").Range("C" & j).Value
        End If
    Next i
End Sub