Excel: Faster Search Through Data

Hello Experts!    
I got somebody on this board put together for me a code that worked well until data volume significantly increased and  the time to complete the routine is now ridiculously long. So, I will be happy if an expert modified the macro in the attached file to become more efficient.

I looked up some methods and suspect use of filters might help, but then I am far from being an expert myself and need a genius solution ASAP...

Thanks, V

Status-Update-Report.xls
NewToVBAAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

TimBusiness Systems AnalystCommented:
Modify the code slightly
Add

Application.Screenupdating = False
at the start and

Application.Screenupdating = True
at the end

This will speed it up.
0
SiddharthRoutCommented:
Try this, This is much much faster then looping through each cell. Sample file Attached. You might see some dates changed. That is because I was testing the code.

Sid

Code Used

Option Explicit

Private Sub CommandButton1_Click()
    Dim lastRowH As Long, LastRowA As Long, i As Long
    Dim ws As Worksheet
    Dim strSearch As String, evnt As String
    Dim aCell As Range, bCell As Range
    Dim dt As Date
    Dim ExitLoop As Boolean
    
    Application.ScreenUpdating = False
    
    Set ws = Sheets("Sheet1")
    
    LastRowA = ws.Range("A" & Rows.Count).End(xlUp).Row
    lastRowH = ws.Range("H" & Rows.Count).End(xlUp).Row
    
    ws.Range("H2:K" & lastRowH).Sort Key1:=ws.Range("H2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    
    For i = 3 To LastRowA
        strSearch = ws.Range("A" & i).Value
        
        Set aCell = ws.Range("H2:H" & lastRowH).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        ExitLoop = False
        dt = 1
        evnt = ""
        
        If Not aCell Is Nothing Then
            Set bCell = aCell
            If aCell.Offset(, 1) = ws.Range("B" & i).Value Then
                If aCell.Offset(, 2).Value > dt Then
                    dt = aCell.Offset(, 2).Value
                    evnt = aCell.Offset(, 3).Value
                End If
            End If
            Do While ExitLoop = False
                Set aCell = ws.Range("H2:H" & lastRowH).FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then
                        If evnt <> "" Then
                            ws.Range("C" & i).Value = dt
                            ws.Range("D" & i).Value = evnt
                        End If
                        Exit Do
                    End If
                    If aCell.Offset(, 1) = ws.Range("B" & i).Value Then
                        If aCell.Offset(, 2).Value > dt Then
                            dt = aCell.Offset(, 2).Value
                            evnt = aCell.Offset(, 3).Value
                        End If
                    End If
                Else
                    If evnt <> "" Then
                            ws.Range("C" & i).Value = dt
                            ws.Range("D" & i).Value = evnt
                        End If
                    ExitLoop = True
                End If
            Loop
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Open in new window

Status-Update-Report.xls
0
SiddharthRoutCommented:
And yes, you may choose to delete lines 18-20 in case you don't want the Col H-K sorted.

Sid
0
Learn SQL Server Core 2016

This course will introduce you to SQL Server Core 2016, as well as teach you about SSMS, data tools, installation, server configuration, using Management Studio, and writing and executing queries.

NewToVBAAuthor Commented:
Hi Sid - I get an error in line 54 when in column J  first of the date records is empty. I tested when dates were missing underneath except the top one and the loop completed with np. We are almost there!

Thank you!

V
0
krishnakrkcCommented:
Hi,

Another option....


Kris
Sub kTest()
Dim ka, k, i As Long, j As Long, r As Range

ka = Application.Intersect(Sheet2.UsedRange, Sheet2.Columns("a:d")) 'Sheet2 data. Adjust columns
Set r = Application.Intersect(Sheet1.UsedRange, Sheet1.Columns("a:d")) 'Sheet1 data. Adjust columns

Const StartRowSheet1    As Long = 3
Const StartRowSheet2    As Long = 2

k = r

For i = StartRowSheet1 To UBound(k, 1)
    If Len(k(i, 1)) Then
        For j = StartRowSheet2 To UBound(ka, 1)
            If ka(j, 1) = k(i, 1) Then
                If ka(j, 2) = k(i, 2) Then
                    If Len(k(i, 3)) = 0 Then
                        k(i, 3) = ka(j, 3)
                        k(i, 4) = ka(j, 4)
                    ElseIf k(i, 3) < ka(j, 3) Then
                        k(i, 3) = ka(j, 3)
                        k(i, 4) = ka(j, 4)
                    End If
                End If
            End If
        Next
    End If
Next
r.Value = k
End Sub

Open in new window

0
SiddharthRoutCommented:
NewToVBA: May I see the data that you tested it with? Might require a small fix. But in general is it faster?

Sid
0
NewToVBAAuthor Commented:
Hi Sid ; I used the file you sent. Clear a cell in J3 (date) and the macro will return a run-time error 13, debug stops as line 54. It appears the issue may be a missing validation for whether or not date is present. It is a legitimate condition that newer records in the data file I use be new with no status date.

tks, V
0
SiddharthRoutCommented:
I did as you said and I didn't get the error. See the snapshot. Or am I missing something?

Sid
Untitled.jpg
0
NewToVBAAuthor Commented:
All I did was this:
1. downloadded the file again, to make sure that I did not confuse versions
2. successfully run the macro with data as it was there
3. clean record in J3 (using spacebar)
4. run the macro again and it immediately stoped with error in the attached image
Debug stops at line # 54:  dt = aCell.Offset(, 2).Value
FYI- I tried this in Excel 2003 and Excel 2007.

tks,V
Error-13.png
0
SiddharthRoutCommented:
Don't use spacebar to clear :), use the Delete button :)

Sid
0
SiddharthRoutCommented:
Anyways use this code. It will cater to deletions using spacebar :)

Option Explicit

Private Sub CommandButton1_Click()
    Dim lastRowH As Long, LastRowA As Long, i As Long
    Dim ws As Worksheet
    Dim strSearch As String, evnt As String
    Dim aCell As Range, bCell As Range
    Dim dt As Date
    Dim ExitLoop As Boolean
    
    Application.ScreenUpdating = False
    
    Set ws = Sheets("Sheet1")
    
    LastRowA = ws.Range("A" & Rows.Count).End(xlUp).Row
    lastRowH = ws.Range("H" & Rows.Count).End(xlUp).Row
    
    ws.Range("H2:K" & lastRowH).Sort Key1:=ws.Range("H2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    
    For i = 3 To LastRowA
        strSearch = ws.Range("A" & i).Value
        
        Set aCell = ws.Range("H2:H" & lastRowH).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        ExitLoop = False
        dt = 1
        evnt = ""
        
        If Not aCell Is Nothing Then
            Set bCell = aCell
            If aCell.Offset(, 1) = ws.Range("B" & i).Value Then
                If aCell.Offset(, 2).Value > dt Then
                    If Len(Trim(aCell.Offset(, 2).Value)) <> 0 Then
                        dt = aCell.Offset(, 2).Value
                        evnt = aCell.Offset(, 3).Value
                    End If
                End If
            End If
            Do While ExitLoop = False
                Set aCell = ws.Range("H2:H" & lastRowH).FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then
                        If evnt <> "" Then
                            ws.Range("C" & i).Value = dt
                            ws.Range("D" & i).Value = evnt
                        End If
                        Exit Do
                    End If
                    If aCell.Offset(, 1) = ws.Range("B" & i).Value Then
                        If Len(Trim(aCell.Offset(, 2).Value)) <> 0 Then
                            dt = aCell.Offset(, 2).Value
                            evnt = aCell.Offset(, 3).Value
                        End If
                    End If
                Else
                    If evnt <> "" Then
                            ws.Range("C" & i).Value = dt
                            ws.Range("D" & i).Value = evnt
                        End If
                    ExitLoop = True
                End If
            Loop
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Open in new window


Sid
0
NewToVBAAuthor Commented:
Hate to say but the macro no loger picks up the correct dates.
I replaced the code with the latest you posted and did an evaluation for each record in the attached file.

sorry to be a pain, but I really need this badly ...

tks, V
Status-Update-Report-4.2.11.xls
0
SiddharthRoutCommented:
Ok use the original file that I posted in ID: 35301277 but do not use spacebar to delete the value of the cell. Use the "DEL" button. Does it work now?

Sid
0
NewToVBAAuthor Commented:
Fair enough. However, I will appreciate an advise on how I can protect the code from crashing when a data record in a source file has been deleted with a space bar? I tested and found plenty of those in the actual produciton data.

I will go ahead and accept your solution.

Many thanks!
Cheers, V
0
SiddharthRoutCommented:
Let me work it for a spacebar.

Sid
0
krishnakrkcCommented:
Hi,

Have you try my code ?

Kris
0
NewToVBAAuthor Commented:
Hi krishnakrkc:, I did. First, the code is amazing fast, and correct when run on few records.
I expanded the range to look through and added new date values, as per attached. unfortunately the code did not return right dates, please check it out.

Tks, V
 krishnakrkc-Test.zip
0
SiddharthRoutCommented:
Ok test this code with the SPACEBAR :)

Option Explicit

Private Sub CommandButton1_Click()
    Dim lastRowH As Long, LastRowA As Long, i As Long
    Dim ws As Worksheet
    Dim strSearch As String, evnt As String
    Dim aCell As Range, bCell As Range
    Dim dt As Date
    Dim ExitLoop As Boolean
    
    Application.ScreenUpdating = False
    
    Set ws = Sheets("Sheet1")
    
    LastRowA = ws.Range("A" & Rows.Count).End(xlUp).Row
    lastRowH = ws.Range("H" & Rows.Count).End(xlUp).Row
    
    ws.Range("H2:K" & lastRowH).Sort Key1:=ws.Range("H2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    
    For i = 3 To LastRowA
        strSearch = ws.Range("A" & i).Value
        
        Set aCell = ws.Range("H2:H" & lastRowH).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        ExitLoop = False
        dt = 1
        evnt = ""
        
        If Not aCell Is Nothing Then
            Set bCell = aCell
            If aCell.Offset(, 1) = ws.Range("B" & i).Value Then
                If Len(Trim(aCell.Offset(, 2).Value)) <> 0 Then
                    If aCell.Offset(, 2).Value > dt Then
                        dt = aCell.Offset(, 2).Value
                        evnt = aCell.Offset(, 3).Value
                    End If
                End If
            End If
            Do While ExitLoop = False
                Set aCell = ws.Range("H2:H" & lastRowH).FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bCell.Address Then
                        If evnt <> "" Then
                            ws.Range("C" & i).Value = dt
                            ws.Range("D" & i).Value = evnt
                        End If
                        Exit Do
                    End If
                    If aCell.Offset(, 1) = ws.Range("B" & i).Value Then
                        If Len(Trim(aCell.Offset(, 2).Value)) <> 0 Then
                            If aCell.Offset(, 2).Value > dt Then
                                dt = aCell.Offset(, 2).Value
                                evnt = aCell.Offset(, 3).Value
                            End If
                        End If
                    End If
                Else
                    If evnt <> "" Then
                            ws.Range("C" & i).Value = dt
                            ws.Range("D" & i).Value = evnt
                        End If
                    ExitLoop = True
                End If
            Loop
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Open in new window


Sid
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
krishnakrkcCommented:
Hi,

Try this


Kris
Sub kTest()
Dim ka, k, i As Long, j As Long, r As Range
Dim lRow    As Long

With Sheet2
    lRow = .Range("a" & .Rows.Count).End(xlUp).Row
    ka = .Range("a3:d" & lRow) 'Sheet2 data. Adjust columns,start row
End With

With Sheet1
    lRow = .Range("a" & .Rows.Count).End(xlUp).Row
    Set r = .Range("a3:d" & lRow) 'Sheet1 data. Adjust columns,start row
End With

k = r

For i = 1 To UBound(k, 1)
    If Len(k(i, 1)) Then
        For j = 1 To UBound(ka, 1)
            If ka(j, 1) = k(i, 1) Then
                If ka(j, 2) = k(i, 2) Then
                    If IsDate(ka(j, 3)) Then
                        If Len(Trim$(k(i, 3))) = 0 Then
                            k(i, 3) = ka(j, 3)
                            k(i, 4) = ka(j, 4)
                        ElseIf k(i, 3) < ka(j, 3) Then
                            k(i, 3) = ka(j, 3)
                            k(i, 4) = ka(j, 4)
                        End If
                    End If
                End If
            End If
        Next
    End If
Next
r.Value = k
MsgBox "Done!"
End Sub

Open in new window

0
NewToVBAAuthor Commented:
Hi Sid and Kris -- many thanks for your solutions, I appreciate your time and effort.
I owe you the well earned points and will split between the two of you.
I must stay that I am astonished how fast Kris' code is. I created  Worsheet1 table with 198 unique records and Worshjeet2 table with over 13k records to search through, and added a timing formula for each code. Tests results show the following cycle time:

Excel 2003:
Sid: 11 minutes
Kris: 3 seconds
 
Excel 2007
Sid:  3 seconds
Kris: 1 second
 
IMy machine runs WIn 7, Intel Core i5, 4G  Ram,

I included the test file if you would like to check it out.

Many thanks to the both of you!

Cheers, V
 Status-Update-Report---comp-Sid-.zip
0
NewToVBAAuthor Commented:
Two great solutions! Thank you very much!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.