Speed up search code

K

KalleK

New Member
Joined
Dec 1, 2016
Messages
18
Hello,

I got the code below. With 24000 rows it takes 42 seconds to execute. Is it possible to do it in another way to speed up?

Kalle


Rich (BB code):
Rich (BB code): 
Private Sub CommandButton5_Click()
    Dim rng1 As Range
    Dim strSearch As String
    Dim V As Variant
    Dim shRow As Long
    
    NotCorrect = 0
    startTime = Timer
    
    ' Speed on
    glb_origCalculationMode = Application.Calculation
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .Cursor = xlWait
        .StatusBar = StatusBarMsg
        .EnableCancelKey = xlErrorHandler
    End With
    
    ' Set Range
    N = Cells(Rows.Count, "A").End(xlUp).Row
    RangeNew = "A1" & ":" & "A" & Str(N)
    RangeNew = Replace(RangeNew, " ", "")
    
    ' Search Sheet2
    Set rRng = Sheets("sheet1").Range(RangeNew)
    For Each rCell In rRng.Cells
        V = Application.Match(rCell.Value, Sheets("Sheet2").Range(RangeNew), 0)
        If IsError(V) Then
            Sheets("sheet1").Cells(rCell.Row, 1).Interior.Color = vbYellow
            NotCorrect = NotCorrect + 1
        Else
        End If
    Next rCell
    
    ' Speed off
    With Application
        .Calculation = glb_origCalculationMode
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .CalculateBeforeSave = True
        .Cursor = xlDefault
        .StatusBar = False
        .EnableCancelKey = xlInterrupt
    End With
    
    EndTime = Timer
    MsgBox "Total Time: " & EndTime - startTime
    MsgBox Str(NotCorrect)
End Sub
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Is it possible to do it in another way to speed up?
Click to expand...

Generally, working with arrays is faster than working with ranges, so you might consider...

*Copying each sheet to its own array
*Running your comparison (maybe a nested For/Next loop)
*If a match isn't found write the first array values to a third array
*At completion, write the third array to a new sheet

Of course, you'll have to run timing tests to see if it's faster than your current approach.

Cheers,

tonyyy
 
Upvote 0
Can you explain what you're trying to do, especially this part:

Code: 
    [COLOR=blue]Set[/COLOR] rRng [B]=[/B] Sheets[B]([/B][COLOR=brown]"sheet1"[/COLOR][B]).[/B]Range[B]([/B]RangeNew[B])[/B]
    [COLOR=blue]For[/COLOR] [COLOR=blue]Each[/COLOR] rCell [COLOR=blue]In[/COLOR] rRng.Cells
        V [B]=[/B] Application.Match[B]([/B]rCell.Value[B],[/B] Sheets[B]([/B][COLOR=brown]"Sheet2"[/COLOR][B]).[/B]Range[B]([/B]RangeNew[B]),[/B] [B][COLOR=crimson]0[/COLOR][/B][B])[/B]
        [COLOR=blue]If[/COLOR] IsError[B]([/B]V[B])[/B] [COLOR=blue]Then[/COLOR]
            Sheets[B]([/B][COLOR=brown]"sheet1"[/COLOR][B]).[/B]Cells[B]([/B]rCell.Row[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]).[/B]Interior.Color [B]=[/B] vbYellow
            NotCorrect [B]=[/B] NotCorrect [B]+[/B] [B][COLOR=crimson]1[/COLOR][/B]
        [COLOR=blue]Else[/COLOR]
        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
    [COLOR=blue]Next[/COLOR] rCell

Are you trying to make the cell in col A yellow if its value has no match with any values in col A sheet2?
 
Upvote 0
Thanks Tonyyy for the comments.

Hello Akuini, yes that is what I want. Check if the values in Col A for sheet1 exist in Col A for sheet2 if not make the row yellow.
 
Upvote 0
Try this:
I use column Z as helper column, you may change that to suit your need.

Code: 
[COLOR=blue]Sub[/COLOR] a1015771b[B]()[/B]
[I][COLOR=seagreen]'sheet1 must be the activesheet[/COLOR][/I]
[COLOR=blue]Dim[/COLOR] N [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR][B],[/B] i [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR]
[COLOR=blue]Dim[/COLOR] va[B],[/B] vc[B],[/B] vz
[COLOR=blue]Dim[/COLOR] NotCorrect [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR]
  
Application.ScreenUpdating [B]=[/B] [COLOR=blue]False[/COLOR]
   
    NotCorrect [B]=[/B] [B][COLOR=crimson]0[/COLOR][/B]
    startTime [B]=[/B] Timer
   
    N [B]=[/B] Cells[B]([/B]Rows.count[B],[/B] [COLOR=brown]"A"[/COLOR][B]).[/B][COLOR=blue]End[/COLOR][B]([/B]xlUp[B]).[/B]row
     vz [B]=[/B] Range[B]([/B][COLOR=brown]"A1:A"[/COLOR] [B]&[/B] N[B]).[/B]Value
      va [B]=[/B] Sheets[B]([/B][COLOR=brown]"sheet2"[/COLOR][B]).[/B]Range[B]([/B][COLOR=brown]"A1:A"[/COLOR] [B]&[/B] N[B]).[/B]Value
       [COLOR=blue]ReDim[/COLOR] vc[B]([/B][B][COLOR=crimson]1[/COLOR][/B] [COLOR=blue]To[/COLOR] UBound[B]([/B]va[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]),[/B] [B][COLOR=crimson]1[/COLOR][/B] [COLOR=blue]To[/COLOR] [B][COLOR=crimson]1[/COLOR][/B][B])[/B]
 
    [COLOR=blue]Set[/COLOR] d [B]=[/B] CreateObject[B]([/B][COLOR=brown]"scripting.dictionary"[/COLOR][B])[/B]
    d.CompareMode [B]=[/B] vbBinaryCompare
   
    [COLOR=blue]For[/COLOR] i [B]=[/B] [B][COLOR=crimson]1[/COLOR][/B] [COLOR=blue]To[/COLOR] UBound[B]([/B]va[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B]
        d[B]([/B]va[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]))[/B] [B]=[/B] [B][COLOR=crimson]1[/COLOR][/B]
    [COLOR=blue]Next[/COLOR]
    [COLOR=blue]If[/COLOR] d.exists[B]([/B][COLOR=brown]""[/COLOR][B])[/B] [COLOR=blue]Then[/COLOR] d.Remove [COLOR=brown]""[/COLOR]
   
   
    [COLOR=blue]For[/COLOR] i [B]=[/B] [B][COLOR=crimson]1[/COLOR][/B] [COLOR=blue]To[/COLOR] UBound[B]([/B]vz[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B]
        [COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] d.exists[B]([/B]vz[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]))[/B] [COLOR=blue]And[/COLOR] vz[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B] [B]<>[/B] [COLOR=brown]""[/COLOR] [COLOR=blue]Then[/COLOR]
            vc[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B] [B]=[/B] [COLOR=brown]"X"[/COLOR]
            NotCorrect [B]=[/B] NotCorrect [B]+[/B] [B][COLOR=crimson]1[/COLOR][/B]
        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
    [COLOR=blue]Next[/COLOR]
 
    [I][COLOR=seagreen]'put the result in helper column Z[/COLOR][/I]
    Range[B]([/B][COLOR=brown]"Z1"[/COLOR][B]).[/B]Resize[B]([/B]UBound[B]([/B]vc[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]),[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B] [B]=[/B] vc
   
    Application.ReplaceFormat.Interior.Color [B]=[/B] vbYellow
    [COLOR=blue]With[/COLOR] Range[B]([/B][COLOR=brown]"Z1:Z"[/COLOR] [B]&[/B] N[B])[/B]
        [B].[/B]Replace What[B]:=[/B][COLOR=brown]"X"[/COLOR][B],[/B] Replacement[B]:=[/B][COLOR=brown]""[/COLOR][B],[/B] lookat[B]:=[/B]xlWhole[B],[/B] _
                 searchFormat[B]:=[/B][COLOR=blue]False[/COLOR][B],[/B] ReplaceFormat[B]:=[/B][COLOR=blue]True[/COLOR]
        [B].[/B]Copy
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
   
    [I][COLOR=seagreen]'clear previous Interior.Color[/COLOR][/I]
    Range[B]([/B][COLOR=brown]"A1:A"[/COLOR] [B]&[/B] N[B]).[/B]Interior.Color [B]=[/B] xlNone
    Range[B]([/B][COLOR=brown]"A1"[/COLOR][B]).[/B]PasteSpecial paste[B]:=[/B]xlPasteFormats
    Columns[B]([/B][COLOR=brown]"Z"[/COLOR][B]).[/B]Delete
 
 
    EndTime [B]=[/B] Timer
    MsgBox [COLOR=brown]"Total Time: "[/COLOR] [B]&[/B] EndTime [B]-[/B] startTime [B]&[/B] vbLf [B]&[/B] _
    [COLOR=brown]"NotCorrect: "[/COLOR] [B]&[/B] str[B]([/B]NotCorrect[B])[/B]
   
Application.ScreenUpdating [B]=[/B] [COLOR=blue]True[/COLOR]
[COLOR=blue]End[/COLOR] [COLOR=blue]Sub[/COLOR]
 
Upvote 0
Thanks Akuini!!!! Very fast code!!!!

Can you help me to change the code like this? This is my goal.
1. Sheet1 and Sheet2 contains 20 columns
2. If the contents of column A in sheet1 if found in Column A in sheet2 but any of the other columns for that row does not match, write gren at column A in sheet1. If it is not found as you have done, write column A in sheet 1 yellow.
 
Last edited:
Upvote 0
KalleK said:
Thanks Akuini!!!! Very fast code!!!!

Can you help me to change the code like this? This is my goal.
1. Sheet1 and Sheet2 contains 20 columns
2. If the contents of column A in sheet1 if found in Column A in sheet2 but any of the other columns for that row does not match, write gren at column A in sheet1. If it is not found as you have done, write column A in sheet 1 yellow.
Click to expand...

I need more info:
Do col A in sheet1 & sheet2 have unique values?
Do sheet1 & sheet2 have the same amount of rows?
 
Upvote 0
Akuini...

Code: 
    For i = 1 To UBound(vz, 1)
        If Not d.exists(vz(i, 1)) And vz(i, 1) <> "" Then
            vc(i, 1) = "X"
            NotCorrect = NotCorrect + 1
        End If
    Next


I like how you utilized the Dictionary object. Thanks for sharing!

tonyyy
 
Upvote 0
Can you help me to change the code like this? This is my goal.
1. Sheet1 and Sheet2 contains 20 columns
2. If the contents of column A in sheet1 if found in Column A in sheet2 but any of the other columns for that row does not match, write gren at column A in sheet1. If it is not found as you have done, write column A in sheet 1 yellow.



I need more info:
Do col A in sheet1 & sheet2 have unique values?
Do sheet1 & sheet2 have the same amount of rows?


Hello Akuini,
1, Yes, Col A have unique values
2. No, the sheets could have different amount of rows

Best Regards
Kalle
 
Upvote 0
OK, try this:

Code: 
[COLOR=blue]Sub[/COLOR] a1015771c[B]()[/B]
[I][COLOR=seagreen]'sheet1 must be the activesheet[/COLOR][/I]
[COLOR=blue]Dim[/COLOR] n [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR][B],[/B] m [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR][B],[/B] i [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR]
[COLOR=blue]Dim[/COLOR] va[B],[/B] vc[B],[/B] vz
[COLOR=blue]Dim[/COLOR] NotCorrect [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR]
  
Application.ScreenUpdating [B]=[/B] [COLOR=blue]False[/COLOR]
   
    NotCorrect [B]=[/B] [B][COLOR=crimson]0[/COLOR][/B]
    startTime [B]=[/B] Timer
   
    n [B]=[/B] Cells[B]([/B]Rows.count[B],[/B] [COLOR=brown]"A"[/COLOR][B]).[/B][COLOR=blue]End[/COLOR][B]([/B]xlUp[B]).[/B]row
    vz [B]=[/B] Range[B]([/B]Cells[B]([/B][B][COLOR=crimson]1[/COLOR][/B][B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]),[/B] Cells[B]([/B]n[B],[/B] [B][COLOR=crimson]20[/COLOR][/B][B])).[/B]Value
    [COLOR=blue]With[/COLOR] Sheets[B]([/B][COLOR=brown]"sheet2"[/COLOR][B])[/B]
        m [B]=[/B] [B].[/B]Cells[B]([/B]Rows.count[B],[/B] [COLOR=brown]"A"[/COLOR][B]).[/B][COLOR=blue]End[/COLOR][B]([/B]xlUp[B]).[/B]row
        va [B]=[/B] [B].[/B]Range[B](.[/B]Cells[B]([/B][B][COLOR=crimson]1[/COLOR][/B][B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]),[/B] [B].[/B]Cells[B]([/B]m[B],[/B] [B][COLOR=crimson]20[/COLOR][/B][B])).[/B]Value
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
      
       [COLOR=blue]ReDim[/COLOR] vc[B]([/B][B][COLOR=crimson]1[/COLOR][/B] [COLOR=blue]To[/COLOR] UBound[B]([/B]va[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]),[/B] [B][COLOR=crimson]1[/COLOR][/B] [COLOR=blue]To[/COLOR] [B][COLOR=crimson]1[/COLOR][/B][B])[/B]
 
    [COLOR=blue]Set[/COLOR] d [B]=[/B] CreateObject[B]([/B][COLOR=brown]"scripting.dictionary"[/COLOR][B])[/B]
    d.CompareMode [B]=[/B] vbTextCompare
   
    [COLOR=blue]For[/COLOR] i [B]=[/B] [B][COLOR=crimson]1[/COLOR][/B] [COLOR=blue]To[/COLOR] UBound[B]([/B]va[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B]
        d[B]([/B]va[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]))[/B] [B]=[/B] [B][COLOR=crimson]1[/COLOR][/B]
    [COLOR=blue]Next[/COLOR]
    [COLOR=blue]If[/COLOR] d.exists[B]([/B][COLOR=brown]""[/COLOR][B])[/B] [COLOR=blue]Then[/COLOR] d.Remove [COLOR=brown]""[/COLOR]
   
   
    [COLOR=blue]For[/COLOR] i [B]=[/B] [B][COLOR=crimson]1[/COLOR][/B] [COLOR=blue]To[/COLOR] UBound[B]([/B]vz[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B]
   
        [COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] d.exists[B]([/B]vz[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]))[/B] [COLOR=blue]Then[/COLOR]
           
            [COLOR=blue]If[/COLOR] vz[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B] [B]<>[/B] [COLOR=brown]""[/COLOR] [COLOR=blue]Then[/COLOR]
                vc[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B] [B]=[/B] [COLOR=brown]"Y"[/COLOR]
                NotCorrect [B]=[/B] NotCorrect [B]+[/B] [B][COLOR=crimson]1[/COLOR][/B]
            [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
       
        [COLOR=blue]Else[/COLOR]
           
            [COLOR=blue]For[/COLOR] j [B]=[/B] [B][COLOR=crimson]1[/COLOR][/B] [COLOR=blue]To[/COLOR] UBound[B]([/B]va[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B]
                [COLOR=blue]If[/COLOR] vz[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B] [B]=[/B] va[B]([/B]j[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B] [COLOR=blue]Then[/COLOR]
                    [COLOR=blue]For[/COLOR] k [B]=[/B] [B][COLOR=crimson]2[/COLOR][/B] [COLOR=blue]To[/COLOR] [B][COLOR=crimson]20[/COLOR][/B]
                        [COLOR=blue]If[/COLOR] vz[B]([/B]i[B],[/B] k[B])[/B] [B]<>[/B] va[B]([/B]j[B],[/B] k[B])[/B] [COLOR=blue]Then[/COLOR]
                            vc[B]([/B]i[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B] [B]=[/B] [COLOR=brown]"G"[/COLOR]
                            [COLOR=blue]Exit[/COLOR] [COLOR=blue]For[/COLOR]
                        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
                    [COLOR=blue]Next[/COLOR]
                [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
            [COLOR=blue]Next[/COLOR]
        [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR]
   
    [COLOR=blue]Next[/COLOR]
 
    [I][COLOR=seagreen]'put the result in helper column Z[/COLOR][/I]
    Range[B]([/B][COLOR=brown]"Z1"[/COLOR][B]).[/B]Resize[B]([/B]UBound[B]([/B]vc[B],[/B] [B][COLOR=crimson]1[/COLOR][/B][B]),[/B] [B][COLOR=crimson]1[/COLOR][/B][B])[/B] [B]=[/B] vc
   
    [COLOR=blue]With[/COLOR] Range[B]([/B][COLOR=brown]"Z1:Z"[/COLOR] [B]&[/B] n[B])[/B]
        Application.ReplaceFormat.Interior.Color [B]=[/B] vbYellow
           [B].[/B]Replace What[B]:=[/B][COLOR=brown]"Y"[/COLOR][B],[/B] Replacement[B]:=[/B][COLOR=brown]""[/COLOR][B],[/B] lookat[B]:=[/B]xlWhole[B],[/B] _
                 searchFormat[B]:=[/B][COLOR=blue]False[/COLOR][B],[/B] ReplaceFormat[B]:=[/B][COLOR=blue]True[/COLOR]
       
        Application.ReplaceFormat.Interior.Color [B]=[/B] vbGreen
           [B].[/B]Replace What[B]:=[/B][COLOR=brown]"G"[/COLOR][B],[/B] Replacement[B]:=[/B][COLOR=brown]""[/COLOR][B],[/B] lookat[B]:=[/B]xlWhole[B],[/B] _
                 searchFormat[B]:=[/B][COLOR=blue]False[/COLOR][B],[/B] ReplaceFormat[B]:=[/B][COLOR=blue]True[/COLOR]
       
        [B].[/B]Copy
    [COLOR=blue]End[/COLOR] [COLOR=blue]With[/COLOR]
   
    Range[B]([/B][COLOR=brown]"A1"[/COLOR][B]).[/B]PasteSpecial paste[B]:=[/B]xlPasteFormats
    Columns[B]([/B][COLOR=brown]"Z"[/COLOR][B]).[/B]Delete
 
Application.ScreenUpdating [B]=[/B] [COLOR=blue]True[/COLOR]
 
    EndTime [B]=[/B] Timer
    MsgBox [COLOR=brown]"Total Time: "[/COLOR] [B]&[/B] EndTime [B]-[/B] startTime [B]&[/B] vbLf [B]&[/B] _
    [COLOR=brown]"NotCorrect: "[/COLOR] [B]&[/B] str[B]([/B]NotCorrect[B])[/B]
   
[COLOR=blue]End[/COLOR] [COLOR=blue]Sub[/COLOR]
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Speeding up VBA
Replies
9
Views
272
jvoss
J
J
  • Question Question
JSON - Parsing
Replies
1
Views
585
pjmorris
P
S
  • Question Question
Need code that adds multiple new rows to table to include a check box in column "L" for each new row
Replies
0
Views
544
sspatriots
S
N
  • Question Question
Code taking too long to end (5 minutes) how to speed up?
Replies
1
Views
569
johnnyL
J
T
  • Question Question
I Need help speeding up this code that takes about 5 mins to run copying data from multiple columns and combining them
Replies
4
Views
411
tonywatsonhelp
T

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top