Slow loading time in excel from VBA for combo box and command button

Question

I created an excel template so I can type in a name and pull from a dropdown list, then populate the next empty cell in a column with the name at the click of the . It works, but is very slow. I used some tricks I found online to help speed it up, but none made a significant increase in speed. I think I may need to store the list in a memory based array which is only run at the opening of the workbook - I believe scanning the list for relevant choices for the drop down is the slowing the process down, but I am not sure about this or how to do this.

Public Sub ListRange_Var()

With Me.ComboBox1

.List = Worksheets("Picklist Options").Range("A3",Worksheets("Picklist Options").Cells(Rows.Count, "A").End(xlUp)).Value

.ListRows = WorksheetFunction.Min(10, .List)

.Dropdown

.LinkedCell = "FWDCalendar!B2"

IF Len(.Text) Then

For I = .ListCount - 1 To 0 Step -1

If InsStr(1, .List(i), .Text, vbTextCompare) = 0 Then .RemoveItem i

Next

.Dropdown

End IF

End With

End Sub


Private Sub ComboBox1_Change()

Dim I as Long

If Not ISArrow Then 

Call ListRange_Var

End Sub



Private Sub ComboBox1_KeyDown(ByVal KeyCode as MS.Forms.ReturnInteger, ByVal Shift As Integer)

IsArrow = KeyCode = vbKeyUp) or (KeyCode = vbKeyDown)

If KeyCode = vbKeyReturn Then Me.ComboBox1.List = Worksheets("Picklist Options").Range("A3", Worksheets("Picklist Options").Cells(Rows.Count, "A").End(xlUp)).Value

End Sub

Answer 1

You can try this, which filters the list before assigning it to the combobox. I see good performance even with 15k items.

This is using a list in ColA and the combobox is on the same worksheet in ColB (positioned on cell selection using the Seelction_change event)

Code is in the worksheet module. I dod see some "ghosting" of the combo as it moves around, but that's another problem.

Option Explicit

Dim IsArrow As Boolean

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rng As Range
    If Target.CountLarge > 1 Then Exit Sub
    Set rng = Application.Intersect(Target, Me.Columns("B"))
    
    Application.ScreenUpdating = False
    With Me.ComboBox1
        If Not rng Is Nothing Then
            
            Debug.Print .LinkedCell
            .Visible = False
            DoEvents
            .Visible = True
            DoEvents
            .LinkedCell = "'" & rng.Parent.Name & "'!" & rng.Address(False, False)
            .Top = rng.Top
            .Left = rng.Left
            .Text = ""
            ListRange_Var
            .Activate
         Else
            .Left = 500
            .LinkedCell = ""
        End If
    End With
End Sub

Public Sub ListRange_Var()
    Dim i As Long
    With Me.ComboBox1
        .List = FilteredList(.Text)
        .ListRows = WorksheetFunction.Min(10, .List)
        .DropDown
    End With
End Sub


Private Sub ComboBox1_Change()
    If Not IsArrow Then ListRange_Var
End Sub

Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    IsArrow = (KeyCode = vbKeyUp) Or (KeyCode = vbKeyDown)
    If KeyCode = vbKeyReturn Then Me.ComboBox1.List = FilteredList
End Sub

'return an array of items, potentially filtered according to
'  user-entered value in combobox
Function FilteredList(Optional v As String = "")
    Dim arr, arrOut, i  As Long, n As Long
    With Worksheets("Picklist Options")
        arr = .Range("A3", .Cells(.Rows.Count, "A").End(xlUp)).Value
    End With
    If Len(v) = 0 Then
        FilteredList = arr
    Else
        arr = Application.Transpose(arr)
        ReDim arrOut(LBound(arr) To UBound(arr))
        n = LBound(arr) - 1
        For i = LBound(arr) To UBound(arr)
            If InStr(1, arr(i), v, vbTextCompare) > 0 Then
                n = n + 1
                arrOut(n) = arr(i)
            End If
        Next i
        If n > LBound(arr) - 1 Then
            ReDim Preserve arrOut(LBound(arrOut) To n)
            FilteredList = arrOut
        Else
            FilteredList = Array("")
        End If
    End If
End Function