Search code examples
excelvbacomboboxactivex

Making a Searchable Combobox to Replace Data Validation with No Helper Columns


I'm building a spreadsheet for staffing purposes. The workbook that contains it is made up of 2 sheets. The one in question and a separate one for validation lists for various different situtations. Currently none are dependant on each other. The two lists in question are for Team Members and Roles. They are both in separate structured tables and both are contained in dual named ranges. The first references the table column directly and the second references the first to make it an indirect reference to the table.

My goal is to make the combobox searchable without the use of helper columns. I had that and it worked somewhat, but because the formulas were volatile it broke easily. The first part of my code I found and adapted to suit my needs. But basically, it makes the combobox appear in any cell that has data validation set for dropdowns and sets some parameters for it. I turned off the validation dropdown to accomodate the combobox and it works nicely. The part I can't seem to get is the "searchable part". In the TempCombo_Keydown sub I try to put the named ranges in arrays and loop through them to make the combobox return only names containing the string of characters typed no matter where in the name they are. To make a long story short I've run into a myriad of errors such as Type Mismatch, Permission Denied, and a few others and every time I think I've fix one another pops up... *Note - All tables are structured tables

I'm by no means a vba guru and I could really use a hand. I've uploaded marked up screenshots because I guess I can't upload the file. If someone would be willing to take a look and help me understand where I'm going wrong and how to get it to work I'd very much appreciate it. Learned a lot doing this so far, but I've hit a wall. Below is the code pertaining to the combobox and I've marked the line where the most recent error is (Permission Denied). I'm happy to answer any questions, thank you! Template Validation Lists

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
    Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet

Set cboTemp = ws.OLEObjects("TempCombo")
  On Error Resume Next
  With cboTemp
  'clear and hide the combo box
    .ListFillRange = vbNull
    .LinkedCell = vbNull
    .Visible = False
  End With
On Error GoTo errHandler
  If Target.Validation.Type = 3 Then
    'if the cell contains
      'a data validation list
    Cancel = True
    Application.EnableEvents = False
    With cboTemp
      'show the combobox with the list
      .Visible = True
      .Left = Target.Left
      .Top = Target.Top
      .Width = Target.Width + 5
      .Height = Target.Height + 5
      .ListFillRange = ""
      .LinkedCell = Target.Address
    End With
    cboTemp.Activate
    'open the drop down list automatically
    Me.TempCombo.DropDown
  End If
  
errHandler:
  Application.EnableEvents = True
  Exit Sub

End Sub

Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
     ByVal Shift As Integer)
  
  Dim arrIn() As Variant
  Dim arrOut() As Variant
  Dim i As Long
  Dim j As Long

  If Not Application.Intersect(ActiveCell, Range("Name")) Is Nothing Then
        arrIn = Sheets("Validation Lists").Range("Tm_11").Value
      Else
      If Not Intersect(ActiveCell, Range("Position")) Is Nothing Then
        arrIn = Sheets("Validation Lists").Range("Role_11").Value
      End If
  End If
   
  ReDim arrOut(1 To UBound(arrIn), 1 To 1)

    For i = 1 To UBound(arrIn)
        If arrIn(i, 1) Like "*" & TempCombo.Text & "*" Then
            j = j + 1
            arrOut(j, 1) = arrIn(i, 1)
        End If
    Next
    TempCombo.List = arrOut 'Location of current "Permission Denied" error
  
  Select Case KeyCode
    Case 9 'Tab
      ActiveCell.Offset(0, 1).Activate
    Case 13 'Enter
      ActiveCell.Offset(1, 0).Activate
    Case Else
        'do nothing
  End Select
End Sub


Private Sub TempCombo_LostFocus()
  Application.ScreenUpdating = False
  With Me.TempCombo
    .Top = 10
    .Left = 10
    .Width = 0
    .ListFillRange = vbNull
    .LinkedCell = vbNull
    .Visible = False
    .Value = vbNull
  End With
  Application.ScreenUpdating = True
End Sub

Solution

  • For anyone interested in knowing... Below is my final code. I was able to achieve what I was looking to do and some. If anyone has any comments or ideas for a better way to achieve the same thing I'd certainly be interested in hearing about it. That being said what I have is working nicely so far!

    I did end up with something a little different than what @FaneDuru and I were discussing above. In researching how to improve on what I already had I came across another similar thread on a different site so I modified that code to my situation, and it works just a little more smoothly.

    Link mentioned above: https://www.mrexcel.com/board/threads/how-to-use-a-combobox-with-autocomplete-and-search-as-you-type.1098277/

    Option Explicit
    
    Private IsArrow As Boolean
    
    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
        Cancel As Boolean)
    Dim str As String
    Dim cboTemp As OLEObject
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Set cboTemp = ws.OLEObjects("TempCombo")
      On Error Resume Next
      With cboTemp
      'clear and hide the combo box
        .ListFillRange = vbNull
        .LinkedCell = vbNull
        .Visible = False
      End With
    On Error GoTo errHandler
      If Target.Validation.Type = 3 Then
        'if the cell contains
          'a data validation list
        Cancel = True
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        With cboTemp
          'show the combobox with the list
          .Visible = True
          .Left = Target.Left
          .Top = Target.Top
          .Width = Target.Width + 5
          .Height = Target.Height + 5
          .ListFillRange = ""
          .LinkedCell = Target.Address
        End With
        cboTemp.Activate
        'open the drop down list automatically
        Me.TempCombo.DropDown
      End If
      
    errHandler:
      Application.EnableEvents = True
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic
      Exit Sub
    
    End Sub
    
    Private Sub TempCombo_Change()
       
    Dim i As Long
        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
        
        If Not IsArrow Then
            With Me.TempCombo
                If Not Application.Intersect(ActiveCell, Range("Name")) Is Nothing Then
                        Me.TempCombo.List = Worksheets("Validation Lists").Range("TM_11").Value
                    Else
                    If Not Intersect(ActiveCell, Range("Position")) Is Nothing Then
                        Me.TempCombo.List = Worksheets("Validation Lists").Range("Role_11").Value
                    End If
                End If
                .ListRows = Application.WorksheetFunction.Min(6, .ListCount)
                If Len(.Text) Then
                    For i = .ListCount - 1 To 0 Step -1
                        If InStr(1, .List(i), .Text, vbTextCompare) = 0 Then .RemoveItem i
                    Next
                End If
            End With
        End If
        
    Application.ScreenUpdating = True
    Application.EnableEvents = True
        
    End Sub
    
    Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
         ByVal Shift As Integer)
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
      IsArrow = (KeyCode = vbKeyUp) Or (KeyCode = vbKeyDown)
        If KeyCode = vbKeyReturn Then
            If Not Application.Intersect(ActiveCell, Range("Name")) Is Nothing Then
                  Me.TempCombo.List = Worksheets("Validation Lists").Range("TM_11").Value
                Else
                If Not Intersect(ActiveCell, Range("Position")) Is Nothing Then
                  Me.TempCombo.List = Worksheets("Validation Lists").Range("Role_11").Value
                End If
             End If
         End If
      
      Select Case KeyCode
        Case 13 'Enter
          ActiveCell.Offset(1, 0).Activate
        Case Else
            'do nothing
      End Select
      
    Application.ScreenUpdating = True
    Application.EnableEvents = True
      
    End Sub
    
    Private Sub TempCombo_LostFocus()
      Application.ScreenUpdating = False
      With Me.TempCombo
        .Top = 10
        .Left = 10
        .Width = 0
        .ListFillRange = vbNull
        .LinkedCell = vbNull
        .Visible = False
        .Value = vbNull
      End With
      Application.ScreenUpdating = True
      Application.Calculation = xlCalculationAutomatic
    End Sub