Speed up code

[KalleK]

Hello all,

I need help to improve the speed of this code (thanks Roxxien for the code)., I I got rows like 20000 the code takes very long to execute .

Please help!!

Kalle


'============================================
Private Sub CommandButton1_Click()


Dim rsheet1 As Range
Dim rsheet2 As Range
Dim bcolor As Boolean




'First loop to compare sheet1 to sheet2
bcolor = False
For Each rsheet1 In Intersect(Sheets("sheet1").UsedRange.Cells, Sheets("sheet1").Range("A:F"))
For Each rsheet2 In Intersect(Sheets("sheet2").UsedRange.Cells,
Sheets("sheet2").Range("A:F"))
If rsheet1 = rsheet2 Then
bcolor = True
GoTo finded1:
End If
Next
finded1:
'If we never finded him, we color
If bcolor = False Then
rsheet1.Interior.ColorIndex = 4
If (rsheet1.Column <> 1) Then
Sheets("sheet1").Cells(rsheet1.Row, 1).Interior.Color = vbYellow
End If

Else
'Reset for next cell to compare
bcolor = False
End If
Next


End Sub
'============================================

 

[Roderick_E]

Hello all,

I need help to improve the speed of this code (thanks Roxxien for the code)., I I got rows like 20000 the code takes very long to execute .

Please help!!

Kalle


'============================================
Private Sub CommandButton1_Click()


Dim rsheet1 As Range
Dim rsheet2 As Range
Dim bcolor As Boolean

'Display wait for a moment
Application.StatusBar = "****Please Wait***** Macro processing"
'opitmize macro by disabling all processes that slow it down.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False


'First loop to compare sheet1 to sheet2
bcolor = False
For Each rsheet1 In Intersect(Sheets("sheet1").UsedRange.Cells, Sheets("sheet1").Range("A:F"))
For Each rsheet2 In Intersect(Sheets("sheet2").UsedRange.Cells,
Sheets("sheet2").Range("A:F"))
If rsheet1 = rsheet2 Then
bcolor = True
GoTo finded1:
End If
Next
finded1:
'If we never finded him, we color
If bcolor = False Then
rsheet1.Interior.ColorIndex = 4
If (rsheet1.Column <> 1) Then
Sheets("sheet1").Cells(rsheet1.Row, 1).Interior.Color = vbYellow
End If

Else
'Reset for next cell to compare
bcolor = False
End If
Next

'Re-enable screenupdating (before END SUB)
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = true
Application.StatusBar = False


End Sub
'============================================

See red additions

 

[KalleK]

Thanks Roderick a little improvement but I need to run in faster ..... It takes a lot of time.

 

[Roxxien]

Hello KalleK,

In both of the range tested, you are currently using column A to F, are you sure that you need to verify every used cells in those 6 columns?

 

[Norie]

What exactly is the code mean to do?

If you are trying to compare values on 2 sheets then perhaps you should look at using Application.Match.

 

[KalleK]

Thanks for the reply. I will try to sort the column and start to compare from a row instead of comparing from the beginning the whole time.

If I have sorted a column, how do I check which rows start with a letter H for example?

Thanks for trying to help me!

 

[KalleK]

Hello Roxxien,

Yes, that is what I want to do. I'm thinking how I could do the algorithm in another way. I have tested the code with only one column and it takes very long time.

 

[Roxxien]

Hello Kallek,

I made some modification. Instead of you using 2 loop 1 cells by 1 cells, I'm using application.Match to look through an entire column. (Thanks for the suggestion Norie)

I don't know if it will really accelerate the macro, but give me some news about it.

Private Sub CommandButton1_Click()




Dim rsheet1 As Range
Dim rsheet2 As Range
Dim bcolor As Boolean
Dim col As Currency


Application.ScreenUpdating = False


'First loop to compare sheet1 to sheet2
bcolor = False
For Each rsheet1 In Intersect(Sheets("sheet1").UsedRange.Cells, Sheets("sheet1").Range("A:F"))
    Do Until col = 6
        col = col + 1
        If IsNumeric(Application.Match(rsheet1, Sheets("sheet2").Columns(col), 0)) Then
            bcolor = True
            GoTo finded1:
        End If
    Loop
finded1:
    'If we never finded him, we color
    If bcolor = False Then
    rsheet1.Interior.ColorIndex = 4
        If (rsheet1.column <> 1) Then
            Sheets("sheet1").Cells(rsheet1.Row, 1).Interior.Color = vbYellow
        End If
    Else
    'Reset for next cell to compare
    bcolor = False
    End If
Next


Application.ScreenUpdating = True
End Sub

 

[Norie]

Roxxien

That should speed things up and is on the lines of what I was thinking about.

For each cell in Sheet1 you are only have 6 iterations in Sheet2.

For example if you were working with A1:F10 (60 cells) on Sheet1 you would 'only' be looping 360 times.

Now let's say you were working with A1:F10 (60 cells) on Sheet1 and A1:F20 (120 cells) on Sheet2 and using the 2 loops from the original code, then you would be looping 60x120 = 7200 times.

 

[Roxxien]

With what I tested, it worked perfectly and instantly colored 6 column of Excel as my sheet2 was empty.

And yes, it reduce by a huge amount the number of operation.

If all 6 columns are completely filled on both sheets, the first code was doing 6*1048576 * 6*1048576 so 3.95842E+13 loops.
With the second version it give 6*1048576*6*1 so 37748736 loops. Only 1048576 times less loop to do.