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