VBA Optimization

[Nickerzzzzz]

Hi All,

Hoping someone can point me in the right direction with regards to optimizing some vba.

The below code takes 12 seconds to run against 3000 cells selected in each worksheet, it looks at one column in each worksheet, looks for a duplicate value and highlights the cell accordingly, the problem is I have 400,000 cells in the first worksheet and 800,000 cells in the second worksheet and it takes an age to run, is there a way to optimise the code so it runs faster?

My vba is limited as I'm pretty much starting out and I have adapted the code found on the forums to suit...from what I can gather I need to read All the cell values into memory/an array, identify the duplicates within the array, and then write the array back to the sheet (Master), trouble is I don't have a clue how to do this and cant find any examples which guide me sufficiently

Any help or pointers would be much appreciated...

********************
Sub CompareRanges()
Dim Count As Integer
Dim StartTime As Double
Dim MinutesElapsed As String
Dim WorkRng1 As Range, WorkRng2 As Range, Rng1 As Range, Rng2 As Range
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
xTitleId = "Find Duplicate String"
Set WorkRng1 = Application.InputBox("Master Range (smallest)", xTitleId, "", Type:=8)
Set WorkRng2 = Application.InputBox("Range To Compare:", xTitleId, Type:=8)
Application.ScreenUpdating = False
StartTime = Timer
For Each Rng1 In WorkRng1
rng1Value = Rng1.Value
For Each Rng2 In WorkRng2
If rng1Value = Rng2.Value Then
Rng1.Interior.Color = VBA.RGB(255, 0, 0)
Exit For
End If
Next
Next
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "The Code Took " & MinutesElapsed & " (hh:mm:ss) To Run", vbInformation
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

********************

 

[Fluff]

Give this a go, it should be a bit faster.

Sub CompareRanges()
    Dim xtitleId As String
    Dim StartTime As Double
    Dim MinutesElapsed As String
    Dim WorkRng1 As Range, WorkRng2 As Range, Rng1 As Range, Rng2 As Range
    
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

    xtitleId = "Find Duplicate String"
    Set WorkRng1 = Application.InputBox("Master Range (smallest)", xtitleId, "", Type:=8)
    Set WorkRng2 = Application.InputBox("Range To Compare:", xtitleId, Type:=8)
    
Application.ScreenUpdating = False

    StartTime = Timer
    For Each Rng1 In WorkRng1
        Set Rng2 = WorkRng2.Find(Rng1.Value, , , xlWhole, , , False, , False)
        If Not Rng2 Is Nothing Then Rng1.Interior.Color = RGB(255, 0, 0)
    Next Rng1
    
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    MsgBox "The Code Took " & MinutesElapsed & " (hh:mm:ss) To Run", vbInformation
    
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

 

[Nickerzzzzz]

Give this a go, it should be a bit faster.
[/CODE]

Wow that's a massive improvement, 12 seconds down to 3 seconds!!, Many Thanks

I'm just running it against the full data set and excel is hanging again, as expected I suppose due to the large amount of data, hopefully it will complete and I can report back the timing, I'm also now trying to understand and translate your loop so I know what is actually going on

Thanks again, much appreciated.

 

[Fennek]

Hello,

without reading your code:

The startegy to accelerate is
- whole range at once to an array
- do all calculation in the array
- copy the result from the array to the sheet at once

Doing this 800,000 rows might be processes in less then a minute

regards

 

[Nickerzzzzz]

Hello,

without reading your code:

The startegy to accelerate is
- whole range at once to an array
- do all calculation in the array
- copy the result from the array to the sheet at once

Doing this 800,000 rows might be processes in less then a minute

regards

Thank you, for confirming my thoughts on strategy, I now need to try and write some code in this way to speed things up some more.

 

[Nickerzzzzz]

Wow that's a massive improvement, 12 seconds down to 3 seconds!!, Many Thanks

I'm just running it against the full data set and excel is hanging again, as expected I suppose due to the large amount of data, hopefully it will complete and I can report back the timing, I'm also now trying to understand and translate your loop so I know what is actually going on

Thanks again, much appreciated.

I ran it against the full data set but it still took an age to run and I couldn't let it finish before having to leave the office.

This morning I have just run the new code against 50,000 lines and time taken to run was 00:10:59, so hoping I can find something to help me write some code using the array strategy to speed things up further?

 

[Fluff]

Because of the amount of data you're looking at, I'm not sure that there is a "quick way" of doing it.
Another approach might be to use a formula, in a blank column on the sheet you want to highlight use this formula & copy down
=MATCH(A2,Records!A2:A20000,0)
Changing sheet name & ranges as required.
Not sure how long it will take, but values that match will return 1 & unmatched values will return #N/A

 

[wideboydixon]

You could try a hash table using Scripting.Dictionary. I haven't tested this in depth though:

Sub CompareRanges()

    Dim xtitleId As String
    Dim StartTime As Double
    Dim MinutesElapsed As String
    Dim WorkRng1 As Range, WorkRng2 As Range, Rng1 As Range, Rng2 As Range
    Dim hashSet As Object
    
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

    xtitleId = "Find Duplicate String"
    Set WorkRng1 = Application.InputBox("Master Range (smallest)", xtitleId, "", Type:=8)
    Set WorkRng2 = Application.InputBox("Range To Compare:", xtitleId, Type:=8)
    Set hashSet = CreateObject("Scripting.Dictionary")
    
Application.ScreenUpdating = False

    StartTime = Timer
    For Each Rng2 In WorkRng2
        If Not hashSet.Exists(Rng2.Value) Then hashSet.Add Rng2.Value, Rng2.Address
    Next Rng2

    For Each Rng1 In WorkRng1
        If Not hashSet.Exists(Rng1.Value) Then Rng1.Interior.Color = RGB(255, 0, 0)
    Next Rng1
    
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    MsgBox "The Code Took " & MinutesElapsed & " (hh:mm:ss) To Run", vbInformation
    
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

WBD

 

[Nickerzzzzz]

You could try a hash table using Scripting.Dictionary. I haven't tested this in depth though:

OMG that's awesome, I just ran your code against the full data set of 400,000/800,000 lines and it completed in under two minutes...amazing, I seriously need to read up and try to understand what the "Scripting.Dictionary" is all about!

Many Thanks Indeed

 

[wideboydixon]

Cool. It's essentially a hash table. See here:

https://en.wikipedia.org/wiki/Hash_table

WBD