Excel VBA loop slow

[shakaib26]

Hi everyone,

i have 80000 rows in "c"column with date in it. i am running below mentioned code to add the combobox list items on combobox change basis. When i run the macro it takes too long time on each change.

Can anybody suggest what to do to speed up the code.


Private Sub ComboBox2_Change()
Dim ws As Worksheet
Set ws = Worksheets("word by word")
Dim Lastrow, r, i As Long

For i = ComboBox2.ListCount - 1 To 0 Step -1
ComboBox2.RemoveItem i
Next i

Lastrow = ws.Range("c" & Rows.Count).End(xlUp).Row
For r = 3 To Lastrow
If InStr(ws.Cells(r, 3), ComboBox2.Text) > 0 Then
ComboBox2.AddItem (ws.Range("c" & r))

'code for showing list unique values only
Dim vArr()
ReDim vArr(1 To ComboBox2.ListCount)
vArr = ComboBox2.List
Dim e
With CreateObject("scripting.dictionary")
.comparemode = 1
For Each e In vArr
If Not .exists(e) Then .Add e, Nothing
Next
If .Count Then ComboBox2.List = (.keys)
End With

End If
If ComboBox2.Text = "" Then
ComboBox2.Clear
End If
Next r
End Sub

 

[shakaib26]

@shakaib26
I created a searchable combobox (in Userform) to get a fast Live Search on large data (tested on 100K data rows).
By live search I mean you get the result instantly after typing each character in the combobox.
How it works:
Type some keywords in the combobox, separated by a space, e.g "ma la", the list in the combobox will be narrowed down as you type.
The search ignores the keywords order, so keywords "ma la" will match "Maryland" and "Alabama"
The result will be displayed after you type the second character. The reason behind this is to speed up the search. Searching with 1 character will return the most results, and on large data sets it can give you a noticeable lag. Searching by 2 characters or more will be faster.
You can set this behavior in this part of the code:

Private Const CN As Long = 2  'start searching after typing certain number of character, change to suit

View attachment 84787

The code:

Option Explicit
Private vList, gList
Private nFlag As Boolean
Private d As Object
Dim oldVAL As String

Private Const CN As Long = 2  'start searching after typing certain number of character, change to suit

Private Sub UserForm_Initialize()
Dim va, x
   
    'load data to va
   With Sheets("Sheet1")
        va = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)) 'data start at B2 downward
   End With
   
        
         Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbBinaryCompare
         For Each x In va
            d(x) = Empty
         Next
       
         If d.Exists("") Then d.Remove ""
         vList = d.keys
         d.RemoveAll
         ComboBox1.MatchEntry = fmMatchEntryNone
        
        
         Label1.Caption = "This is a searchable combobox (in Userform) to get a fast Live Search on large data"

End Sub

Private Sub ComboBox1_Change()

Dim tx1 As String
    With ComboBox1
            If nFlag = True Then Exit Sub 'don't change the list when combobox1 value is changed by DOWN ARROW or UP ARROW key
 
            tx1 = Trim(.Text)
            If Len(tx1) < CN Then .Clear:  oldVAL = tx1: gList = Empty: Exit Sub
           
            If tx1 = oldVAL Then Exit Sub
 
            If tx1 <> "" Then
                    If InStr(1, tx1, oldVAL, vbBinaryCompare) = 1 And Len(tx1) > Len(oldVAL) And Not IsEmpty(gList) Then
                        Call get_filterX(gList)
                    Else
                        Call get_filterX(vList)
                        gList = Empty
                    End If
                   
                    .List = d.keys
                    If d.Count = 0 Then gList = Empty Else gList = d.keys
                    d.RemoveAll
                    .DropDown

            Else
                    .Clear 'if Combobox1 is empty then clear the list

'                    .List = vList   'if combobox1 is empty then get whole list
            End If
       
        oldVAL = Trim(tx1)
    End With


End Sub

Sub get_filterX(ary)
'search without keyword order, case insensitive
Dim i As Long, x, z, q
Dim v As String
Dim flag As Boolean
   
    d.RemoveAll
    z = Split(UCase(ComboBox1.Value), " ")

    For Each x In ary
        flag = True: v = UCase(x)
            For Each q In z
                If InStr(1, v, q, vbBinaryCompare) = 0 Then flag = False: Exit For
            Next
        If flag = True Then d(x) = Empty
    Next

End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

nFlag = False
    Select Case KeyCode
        Case vbKeyDown, vbKeyUp
             nFlag = True 'don't change the list when combobox1 value is changed by DOWN ARROW or UP ARROW key
    End Select
End Sub

the workbook:

Akuini - userform - searchable combobox, no sort, no limit, start at n char #1

MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.

www.mediafire.com

Hi

WOW thats great job as per my requirement and very fast.
Can you help more if i want to search the characters at start of word no need to search in mid or end of the word?

Thank you so much.

 

[Akuini]

Can you help more if i want to search the characters at start of word no need to search in mid or end of the word?

Can you give us some examples?

 

[shakaib26]

Can you give us some examples?

Hi
Thanks for your reply

Like there are 3 parts in a name
Name: Khawaja Muhammad Shakaib
I need it should show results only on starting characters like khaw, muh, shak ie.......
But not shows results of mid characters like waja, mmad, aib ie......
Hopefully you will have understand what i want.

 

[shakaib26]

Hi
Thanks for your reply

Like there are 3 parts in a name
Name: Khawaja Muhammad Shakaib
I need it should show results only on starting characters like khaw, muh, shak ie.......
But not shows results of mid characters like waja, mmad, aib ie......
Hopefully you will have understand what i want.

Like i start my search from waja, mmad, aib so, it should not show the results.

 

[Akuini]

Hi
Thanks for your reply

Like there are 3 parts in a name
Name: Khawaja Muhammad Shakaib
I need it should show results only on starting characters like khaw, muh, shak ie.......
But not shows results of mid characters like waja, mmad, aib ie......
Hopefully you will have understand what i want.

Do all names have 3 parts?

 

[shakaib26]

Do all names have 3 parts?

No this is only example. Name can be also in 1 word

 

[Akuini]

If you type "mu khaw" do you expect it to match "Khawaja Muhammad Shakaib"? so the order of the keywords is irrelevant?

 

[shakaib26]

If you type "mu khaw" do you expect it to match "Khawaja Muhammad Shakaib"? so the order of the keywords is irrelevant?

It should match only by typing "khaw"
If i search on muh ie.... Then it will also bring irrelevent words or names which last or mid characters are matching
Like there are two names "Khawaja Muhammad Shakaib" and other is "Muhammad Aslam"
I need names with khawaja if i search with keyword "muh" then it will bring khawaja but also bring "Muhammad Aslam" which i don't need and it will also increase the combobox list volume.

 

[shakaib26]

T

So the keyword order matters, right?
Keyword "khaw mu" should match "Khawaja Muhammad Shakaib" but keyword "mu khaw" shouldn't.
Keyword "khaw" should match "Khawaja Muhammad Shakaib" but not "Shakaib Khawaja"
Try replacing "Sub get_filterX(ary)" with this:

Sub get_filterX(ary)
'search without keyword order, case insensitive
'Like there are 3 parts in a name
'Name: Khawaja Muhammad Shakaib
'I need it should show results only on starting characters like khaw, muh, shak ie.......
'But not shows results of mid characters like waja, mmad, aib ie......

Dim i As Long, x, z, q, sv
Dim v As String
Dim flag As Boolean
   
    d.RemoveAll
    z = Split(UCase(ComboBox1.Value), " ")

    For Each x In ary
        flag = True: v = UCase(x)
        sv = Split(v, " ")
            If InStr(1, v, z(0), vbBinaryCompare) = 1 Then
                For i = 1 To UBound(z)
                    If i > UBound(sv) Then
                        flag = False: Exit For
                    Else
                         If InStr(1, sv(i), z(i), vbBinaryCompare) <> 1 Then flag = False: Exit For
                    End If
                Next
            Else
                flag = False
            End If
           
        If flag = True Then d(x) = Empty
    Next

End Sub

Thanks

Now it's perfect as per my requirement. Great work.
But only one problem in combobox list its showing only name which is in the start but it is now showing which is in 2nd or 3rd part of name, but when i populate the list data to listbox there is shows all name even 1st, 2nd or 3rd.

 

[Akuini]

but when i populate the list data to listbox there is shows all name even 1st, 2nd or 3rd.

How do you populate the list data to listbox?