• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Speed up Lookup Function?

TomNR

TomNR

Member
Hi all,

I currently have a lookup feature built but it takes 15-30 seconds to search through all 11500 rows of data.

I was wondering if there is a quicker method than the one I am using or if it is because of the size of the data it is searching through?

Thanks in advance!

Code: 
Sub Lookup()
'declare variables
    Dim rngFind As Range
    Dim strFirstFind As String

    'error statement
    On Error GoTo errHandler:

    'clear the listbox
    lstLookup.Clear

    'look up parts or all of full name
    With Sheet7.Range("A:A")
        Set rngFind = .Find(txtLookup.Text, LookIn:=xlValues, lookat:=xlPart)
        'if value found then set a variable for the address
        If Not rngFind Is Nothing Then
            strFirstFind = rngFind.Address
            'add the values to the listbox
            Do
                If rngFind.Row > 1 Then
                    lstLookup.AddItem rngFind.Value
                    lstLookup.List(lstLookup.ListCount - 1, 1) = rngFind.Offset(0, 1)
                End If
                'find the next address to add
                Set rngFind = .FindNext(rngFind)
            Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstFind
        End If
    End With

    'error block
    On Error GoTo 0
    Exit Sub

errHandler::
    MsgBox "An Error has Occurred  " & vbCrLf & "The error number is:  " _
          & Err.Number & vbCrLf & Err.Description & vbCrLf & _
          "Please notify the administrator"
End Sub
 
Marc L said:
Hi !

During execution, desactivate display via ScreenUpdating property …
​
Click to expand...
I wish it was this easy, unfortunately it is not the ScreenUpdating that is the issue it is the amount of data it is searching through. (thank you for the suggestion though!)

I was wondering if there was a better method (i.e. VLookup) that would speed up this section of code?

Any help would be most appreciated!

Code: 
    'look up parts or all of full name
  With Sheet7.Range("A:A")
        Set rngFind = .Find(txtLookup.Text, LookIn:=xlValues, lookat:=xlPart)
        'if value found then set a variable for the address
      If Not rngFind Is Nothing Then
            strFirstFind = rngFind.Address
            'add the values to the listbox
          Do
                If rngFind.Row > 1 Then
                    lstLookup.AddItem rngFind.Value
                    lstLookup.List(lstLookup.ListCount - 1, 1) = rngFind.Offset(0, 1)
                End If
                'find the next address to add
              Set rngFind = .FindNext(rngFind)
            Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstFind
        End If
    End With
 
I'd suggest an array:

Code: 
Private Sub CommandButton1_Click()
  Dim vData
  Dim lLastRow  As Long
  Dim n  As Long
  Dim lCount  As Long
  Dim lCounter  As Long
  Dim sMatch  As String
  Dim asMatches()  As String

  sMatch = VBA.UCase$(txtLookup.Text)
  With Sheet7
  lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  lCount = Application.WorksheetFunction.CountIf(.Range("A1:A" & lLastRow), "*" & sMatch & "*")
  If lCount > 0 Then
  ReDim asMatches(1 To lCount, 1 To 2)
  lCounter = 1
  vData = .Range("A1:B" & lLastRow).Value2
  For n = 1 To UBound(vData, 1)
  If InStr(1, VBA.UCase$(vData(n, 1)), sMatch) <> 0 Then
  asMatches(lCounter, 1) = vData(n, 1)
  asMatches(lCounter, 2) = vData(n, 2)
  lCounter = lCounter + 1
  End If
  Next n
  lstLookup.List = asMatches
  Else
  lstLookup.Clear
  End If
  End With
End Sub
 
Debaser said:
I'd suggest an array:

Code: 
Private Sub CommandButton1_Click()
  Dim vData
  Dim lLastRow  As Long
  Dim n  As Long
  Dim lCount  As Long
  Dim lCounter  As Long
  Dim sMatch  As String
  Dim asMatches()  As String

  sMatch = VBA.UCase$(txtLookup.Text)
  With Sheet7
  lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  lCount = Application.WorksheetFunction.CountIf(.Range("A1:A" & lLastRow), "*" & sMatch & "*")
  If lCount > 0 Then
  ReDim asMatches(1 To lCount, 1 To 2)
  lCounter = 1
  vData = .Range("A1:B" & lLastRow).Value2
  For n = 1 To UBound(vData, 1)
  If InStr(1, VBA.UCase$(vData(n, 1)), sMatch) <> 0 Then
  asMatches(lCounter, 1) = vData(n, 1)
  asMatches(lCounter, 2) = vData(n, 2)
  lCounter = lCounter + 1
  End If
  Next n
  lstLookup.List = asMatches
  Else
  lstLookup.Clear
  End If
  End With
End Sub
Click to expand...
Thanks for the reply Debaser!

It seems like your code doesn't break anything (no debug messages) but it doesn't populate the ListBox with the results of the Lookup value.

So I see it takes the sMatch from the txtLookup.text box on the Userform.

Then it search Sheet7, Column A for that value.

Once it finds it I do not understand how it is pulling the data found into the ListBox. I assume it is the asMatches but it is not working currently?

Once again thank you for the response!
 
Can you even post a small sample file so we can see what is going on ?
 
Are you looking up numbers, or text? The code would need a change if you are looking up number values.
 
Hui said:
Can you even post a small sample file so we can see what is going on ?
Click to expand...
ANKUSHRS1 said:
pls share sample file which you are using now.
Click to expand...

Of course, please find attached a sample file.

Basically if you click 'Add Project' it brings up a userform.

Then type in 1, 2 or 3. That brings up the results from the PivotTable in Sheet7.

Double click the result in the listbox, which populates the Userform. Then you type in your new value and click add to add it to a comparison table.

So this is all working fine and dandy but when you have 11500 rows of data in the pivot table it takes 20-30 seconds to search in the Userform which is not ideal.

Any suggestions on speeding this process up would be much appreciated!
 

Attachments

  • Lookup Speed.xlsm
    556.5 KB · Views: 9
To look up numbers, try this:
Code: 
Sub Lookup()
    Dim vData
    Dim lLastRow              As Long
    Dim n                     As Long
    Dim lCount                As Long
    Dim lCounter              As Long
    Dim sMatch                As String
    Dim asMatches()           As String

    sMatch = VBA.UCase$(txtLookup.Text)
    lstLookup.Clear
    With Sheet7
        lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        ReDim asMatches(1 To 2, 1 To lLastRow)
        vData = .Range("A1:B" & lLastRow).Value2
        For n = 1 To UBound(vData, 1)
            If InStr(1, VBA.UCase$(vData(n, 1)), sMatch) <> 0 Then
                lCounter = lCounter + 1
                asMatches(1, lCounter) = vData(n, 1)
                asMatches(2, lCounter) = vData(n, 2)
            End If
        Next n
        If lCounter > 0 Then
            ReDim Preserve asMatches(1 To 2, 1 To lCounter)
            lstLookup.Column = asMatches
        End If
    End With
    Me.reg1.Enabled = False
    Me.reg2.Enabled = False
    Me.reg3.Enabled = False
    'error block
    On Error GoTo 0
    Exit Sub
errHandler::
    MsgBox "An Error has Occurred  " & vbCrLf & "The error number is:  " _
         & Err.Number & vbCrLf & Err.Description & vbCrLf & _
           "Please notify the administrator"
End Sub
 
Debaser said:
To look up numbers, try this:
Code: 
Sub Lookup()
    Dim vData
    Dim lLastRow              As Long
    Dim n                     As Long
    Dim lCount                As Long
    Dim lCounter              As Long
    Dim sMatch                As String
    Dim asMatches()           As String

    sMatch = VBA.UCase$(txtLookup.Text)
    lstLookup.Clear
    With Sheet7
        lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        ReDim asMatches(1 To 2, 1 To lLastRow)
        vData = .Range("A1:B" & lLastRow).Value2
        For n = 1 To UBound(vData, 1)
            If InStr(1, VBA.UCase$(vData(n, 1)), sMatch) <> 0 Then
                lCounter = lCounter + 1
                asMatches(1, lCounter) = vData(n, 1)
                asMatches(2, lCounter) = vData(n, 2)
            End If
        Next n
        If lCounter > 0 Then
            ReDim Preserve asMatches(1 To 2, 1 To lCounter)
            lstLookup.Column = asMatches
        End If
    End With
    Me.reg1.Enabled = False
    Me.reg2.Enabled = False
    Me.reg3.Enabled = False
    'error block
    On Error GoTo 0
    Exit Sub
errHandler::
    MsgBox "An Error has Occurred  " & vbCrLf & "The error number is:  " _
         & Err.Number & vbCrLf & Err.Description & vbCrLf & _
           "Please notify the administrator"
End Sub
Click to expand...

Hi Debaser,

Some of the project numbers I have are 10056A 100765B & XBM16HJ7 (sorry for not including that in the sample file) so I'm not sure if your method would still work?

Thanks for the help so far!
 
Debaser said:
You're welcome.
Click to expand...
Just one last area that you might be able to help with.

So the search is super quick now!!

The only bit of slow down happens when double clicking the value from the ListBox that you wish to add to the Userform.

However it only takes a long time the further down the list you go.

So for instance if you want to add a project that is on row 10500 then it takes 10-15 seconds to add the data into the Userform.

Is there a miracle method like your search function that would work for adding the data to the userform?

Thank you again in advance!
 
The simplest way is either to store all the data in the listbox, or at least store the row numbers from the original search. I'll do the latter here.

Change the listbox to have a ColumnCount of 3 and set the column width of the last column to 0.

Then change your lookup code to:
Code: 
Sub Lookup()
    Dim vData
    Dim lLastRow              As Long
    Dim n                     As Long
    Dim lCount                As Long
    Dim lCounter              As Long
    Dim sMatch                As String
    Dim asMatches()           As String

    sMatch = VBA.UCase$(txtLookup.Text)
    lstLookup.Clear
    With Sheet7
        lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        ReDim asMatches(1 To 3, 1 To lLastRow)
        vData = .Range("A1:B" & lLastRow).Value2
        For n = 1 To UBound(vData, 1)
            If InStr(1, VBA.UCase$(vData(n, 1)), sMatch) <> 0 Then
                lCounter = lCounter + 1
                asMatches(1, lCounter) = vData(n, 1)
                asMatches(2, lCounter) = vData(n, 2)
                asMatches(3, lCounter) = n
            End If
        Next n
        If lCounter > 0 Then
            ReDim Preserve asMatches(1 To 3, 1 To lCounter)
            lstLookup.Column = asMatches
        End If
    End With
    Me.reg1.Enabled = False
    Me.reg2.Enabled = False
    Me.reg3.Enabled = False
    'error block
    On Error GoTo 0
    Exit Sub
errHandler::
    MsgBox "An Error has Occurred  " & vbCrLf & "The error number is:  " _
         & Err.Number & vbCrLf & Err.Description & vbCrLf & _
           "Please notify the administrator"
End Sub

Now the listbox code can just be:
Code: 
Private Sub lstLookup_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'declare the variables
    Dim lRow                  As Long

    With Me.lstLookup
        ' get row number
        lRow = .List(.ListIndex, 2)
    End With

    'add the database values to the userform
    cNum = 4
    For X = 1 To cNum
        Me.Controls("reg" & X).Value = Sheet7.Cells(lRow, X).Value
    Next
End Sub
as there's no need to search for the data.
 
Last edited:
Debaser said:
The simplest way is either to store all the data in the listbox, or at least store the row numbers from the original search. I'll do the latter here.

Change the listbox to have a ColumnCount of 3 and set the column width of the last column to 0.

Then change your lookup code to:
Code: 
Sub Lookup()
    Dim vData
    Dim lLastRow              As Long
    Dim n                     As Long
    Dim lCount                As Long
    Dim lCounter              As Long
    Dim sMatch                As String
    Dim asMatches()           As String

    sMatch = VBA.UCase$(txtLookup.Text)
    lstLookup.Clear
    With Sheet7
        lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        ReDim asMatches(1 To 3, 1 To lLastRow)
        vData = .Range("A1:B" & lLastRow).Value2
        For n = 1 To UBound(vData, 1)
            If InStr(1, VBA.UCase$(vData(n, 1)), sMatch) <> 0 Then
                lCounter = lCounter + 1
                asMatches(1, lCounter) = vData(n, 1)
                asMatches(2, lCounter) = vData(n, 2)
                asMatches(3, lCounter) = n
            End If
        Next n
        If lCounter > 0 Then
            ReDim Preserve asMatches(1 To 3, 1 To lCounter)
            lstLookup.Column = asMatches
        End If
    End With
    Me.reg1.Enabled = False
    Me.reg2.Enabled = False
    Me.reg3.Enabled = False
    'error block
    On Error GoTo 0
    Exit Sub
errHandler::
    MsgBox "An Error has Occurred  " & vbCrLf & "The error number is:  " _
         & Err.Number & vbCrLf & Err.Description & vbCrLf & _
           "Please notify the administrator"
End Sub

Now the listbox code can just be:
Code: 
Private Sub lstLookup_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'declare the variables
    Dim lRow                  As Long

    With Me.lstLookup
        ' get row number
        lRow = .List(.ListIndex, 2)
    End With

    'add the database values to the userform
    cNum = 4
    For X = 1 To cNum
        Me.Controls("reg" & X).Value = Sheet7.Cells(lRow, X).Value
    Next
    Exit Sub
End Sub
as there's no need to search for the data.
Click to expand...


You my friend are a life saver!!!

Thank you so much for this, the code is so much cleaner as well!

Funny when you work on something only to find it can be done 100x better, it is what I love about this site!!!

Thanks again Debaser! :)
 
You must log in or register to reply here.
Back
Top