Compare rows between 2 sheets - slow

[Jeff5019]

Hi,

This works but can anyone think of a way to make it faster? It needs to look through over 15,000 rows.

Set Sh_1 = ActiveWorkbook.Sheets("NFC Allocations")
        Set Sh_2 = ActiveWorkbook.Sheets("RSL")
       
       
       For r = 2 To Sh_1.UsedRange.Rows.Count
       For s = 2 To Sh_2.UsedRange.Rows.Count
             
             If Sh_2.Cells(s, 1) = Sh_1.Cells(r, 1) Then
    
                 Sh_2.Cells(s, 1).Interior.ColorIndex = 6
                 Sh_1.Cells(r, 1).Interior.ColorIndex = 3
        
              End If
    
        Next s
        Next r

 

[b.downey]

Try using the following code prior to entering the LOOPs

Application.ScreenUpdating = False

After you complete the LOOPs, revert the property back to normal

Application.ScreenUpdating = True

 

[mirabeau]

Hi,

This works but can anyone think of a way to make it faster? It needs to look through over 15,000 rows.

etc, etc

Hi Jeff,

Main ways in which slowness can be improved in your example are:
- Use arrays instead of direct worksheet cell comparisons
- Turn off screen updating (as otherwise noted)
- Avoid the loop within a loop. This greatly increases the number of actions your computer must take
- Color groups of cells (ranges) all at once rather than just single cells one by one.

If you've got 15,000 rows, just using arrays might give you an adequate increase in speed. Code below does this. Post back if still not fast enough.

Sub test()
Dim ra As Long, rb As Long
Dim a As Variant, b As Variant
Dim r As Long, s As Long
Dim Sh_1 As Worksheet, Sh_2 As Worksheet
   
   Set Sh_1 = ActiveWorkbook.Sheets("NFC Allocations")
    Set Sh_2 = ActiveWorkbook.Sheets("RSL")
 
    
    ra = Sh_1.Range("A" & Rows.Count).End(3).Row
    a = Sh_1.Range("A1").Resize(ra)
    rb = Sh_2.Range("A" & Rows.Count).End(3).Row
    b = Sh_2.Range("A1").Resize(ra)


For r = 2 To ra
       For s = 2 To rb
             
             If b(s, 1) = a(r, 1) Then
    
                 Sh_2.Cells(s, 1).Interior.ColorIndex = 6
                 Sh_1.Cells(r, 1).Interior.ColorIndex = 3
        
              End If
    
        Next s
Next r


End Sub

 

[Jeff5019]

Hi Jeff,

Main ways in which slowness can be improved in your example are:
- Use arrays instead of direct worksheet cell comparisons
- Turn off screen updating (as otherwise noted)
- Avoid the loop within a loop. This greatly increases the number of actions your computer must take
- Color groups of cells (ranges) all at once rather than just single cells one by one.

If you've got 15,000 rows, just using arrays might give you an adequate increase in speed. Code below does this. Post back if still not fast enough.

Sub test()
Dim ra As Long, rb As Long
Dim a As Variant, b As Variant
Dim r As Long, s As Long
Dim Sh_1 As Worksheet, Sh_2 As Worksheet
   
   Set Sh_1 = ActiveWorkbook.Sheets("NFC Allocations")
    Set Sh_2 = ActiveWorkbook.Sheets("RSL")
 
    
    ra = Sh_1.Range("A" & Rows.Count).End(3).Row
    a = Sh_1.Range("A1").Resize(ra)
    rb = Sh_2.Range("A" & Rows.Count).End(3).Row
    b = Sh_2.Range("A1").Resize(ra)


For r = 2 To ra
       For s = 2 To rb
             
             If b(s, 1) = a(r, 1) Then
    
                 Sh_2.Cells(s, 1).Interior.ColorIndex = 6
                 Sh_1.Cells(r, 1).Interior.ColorIndex = 3
        
              End If
    
        Next s
Next r


End Sub

Thanks for the response. I already had screenupdating turned off... I just didn't include it here. I am getting "Run-Time error '9': Subscript out of range" at this line:

 If b(s, 1) = a(r, 1) Then

It seems to find the first value and change the cell colors correctly. But when it moves on to the second value it errors out.

Thoughts?

 

[mirabeau]

Thanks for the response. I already had screenupdating turned off... I just didn't include it here. I am getting "Run-Time error '9': Subscript out of range" at this line:

 If b(s, 1) = a(r, 1) Then

It seems to find the first value and change the cell colors correctly. But when it moves on to the second value it errors out.

Thoughts?

looks like I made a misprint in the red line. Try this modified version

Sub test()
Dim ra As Long, rb As Long
Dim a As Variant, b As Variant
Dim r As Long, s As Long
Dim Sh_1 As Worksheet, Sh_2 As Worksheet
   
   Set Sh_1 = ActiveWorkbook.Sheets("NFC Allocations")
    Set Sh_2 = ActiveWorkbook.Sheets("RSL")
     
    ra = Sh_1.Range("A" & Rows.Count).End(3).Row
    a = Sh_1.Range("A1").Resize(ra)
    rb = Sh_2.Range("A" & Rows.Count).End(3).Row
    b = Sh_2.Range("A1").Resize(rb)

For r = 2 To ra
       For s = 2 To rb
             
             If b(s, 1) = a(r, 1) Then
    
                 Sh_2.Cells(s, 1).Interior.ColorIndex = 6
                 Sh_1.Cells(r, 1).Interior.ColorIndex = 3
        
              End If
    
        Next s
Next r

End Sub

 

[Jeff5019]

looks like I made a misprint in the red line. Try this modified version

Sub test()
Dim ra As Long, rb As Long
Dim a As Variant, b As Variant
Dim r As Long, s As Long
Dim Sh_1 As Worksheet, Sh_2 As Worksheet
   
   Set Sh_1 = ActiveWorkbook.Sheets("NFC Allocations")
    Set Sh_2 = ActiveWorkbook.Sheets("RSL")
     
    ra = Sh_1.Range("A" & Rows.Count).End(3).Row
    a = Sh_1.Range("A1").Resize(ra)
    rb = Sh_2.Range("A" & Rows.Count).End(3).Row
    b = Sh_2.Range("A1").Resize(rb)

For r = 2 To ra
       For s = 2 To rb
             
             If b(s, 1) = a(r, 1) Then
    
                 Sh_2.Cells(s, 1).Interior.ColorIndex = 6
                 Sh_1.Cells(r, 1).Interior.ColorIndex = 3
        
              End If
    
        Next s
Next r

End Sub

That did it!! I love learning new things. I use a lot of loops so this will help me a lot. I feel I should have caught the that last problem myself though. I often copy code that I've written and paste it over and over again. Sometimes I forget to change a variable and I get that error.

Anyway... thank you again for you help. This is excellent code.

 

[mirabeau]

That did it!! I love learning new things. I use a lot of loops so this will help me a lot. I feel I should have caught the that last problem myself though. I often copy code that I've written and paste it over and over again. Sometimes I forget to change a variable and I get that error.

Anyway... thank you again for you help. This is excellent code.

Hi Jeff,

Thanks for your comments and I'm glad it was of some help.

Afterwards I considered a bit and decided that a code with 15000^2 iterations wasn't going to be that fast anyway.

Here's a faster one, took less than 0.2secs to run for 15,000 rows on each sheet. Not the sort of code that I like writing though, too long and convoluted, so am posting it here for mainly the record rather than keeping it on my own computer.

Sub test2()
Dim ra As Long, rb As Long
Dim a As Variant, b As Variant
Dim r As Long, s As Long, ka As Long, kb As Long
Dim Sh_1 As Worksheet, Sh_2 As Worksheet
Dim d1 As Object, d2 As Object
Dim xa() As String, xb() As String
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set Sh_1 = ActiveWorkbook.Sheets("sheet1") '("NFC Allocations")
Set Sh_2 = ActiveWorkbook.Sheets("sheet2") '("RSL")
    ra = Sh_1.Range("A" & Rows.Count).End(3).Row
    a = Sh_1.Range("A1").Resize(ra)
    rb = Sh_2.Range("A" & Rows.Count).End(3).Row
    b = Sh_2.Range("A1").Resize(rb)
ka = 1: kb = 1
ReDim xa(1 To 10), xb(1 To 10)
For r = 2 To ra
       d1(a(r, 1)) = 1
Next r


For s = 2 To rb
    d2(b(s, 1)) = 1
    If d1(b(s, 1)) = 1 Then
        If Len(xb(kb)) + Len(",A" & s) < 255 Then
            xb(kb) = xb(kb) & ",A" & s
        Else
            kb = kb + 1
            If kb > UBound(xb) Then ReDim Preserve xb(1 To kb)
        End If
    End If


Next s


For r = 2 To ra
    If d2(a(r, 1)) = 1 Then
        If Len(xa(ka)) + Len(",A" & r) < 255 Then
            xa(ka) = xa(ka) & ",A" & r
        Else
            ka = ka + 1
            If ka > UBound(xa) Then ReDim Preserve xa(1 To ka)
        End If
    End If
Next r


Sh_1.Activate
    For r = 1 To ka
        Range(Right(xa(r), Len(xa(r)) - 1)).Interior.Color = vbYellow
    Next r


Sh_2.Activate
    For s = 1 To kb
        Range(Right(xb(s), Len(xb(s)) - 1)).Interior.Color = vbRed
    Next s


End Sub