制作一个可搜索的组合框来替换没有辅助列的数据验证

Question

我正在构建一个用于人员配备的电子表格。包含它的工作簿由 2 张纸组成。有问题的一个和一个单独的用于各种不同情况的验证列表。目前 none 相互依赖。有问题的两个列表是针对团队成员和角色的。它们都在单独的结构化 table 中，并且都包含在双重命名范围中。第一个直接引用 table 列，第二个引用第一个使其间接引用 table.

我的目标是在不使用辅助列的情况下使组合框可搜索。我有那个，它有点用，但因为公式不稳定，所以很容易坏掉。我发现并调整了我的代码的第一部分以满足我的需要。但基本上，它使组合框出现在任何为下拉菜单设置数据验证并为其设置一些参数的单元格中。我关闭了验证下拉菜单以适应组合框，它工作得很好。我似乎无法获得的部分是“可搜索部分”。在 TempCombo_Keydown 子中，我尝试将命名范围放入数组中并循环遍历它们以使组合框 return 仅包含包含键入的字符串的名称，无论它们在名称中的位置如何。长话短说，我运行遇到了无数错误，例如类型不匹配、权限被拒绝和其他一些错误，每次我认为我已经修复了另一个时，都会弹出... *注意 -所有 table 都是结构化的 tables

我绝不是 vba 大师，我真的可以用一只手。我上传了标记的屏幕截图，因为我想我无法上传文件。如果有人愿意看一下并帮助我了解我哪里出错了以及如何让它工作，我将非常感激。到目前为止，这样做学到了很多东西，但我遇到了困难。下面是与组合框有关的代码，我标记了最近错误所在的行（权限被拒绝）。我很乐意回答任何问题，谢谢！

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

Answer 1

任何有兴趣了解的人...下面是我的最终代码。我能够实现我想要做的事情和一些。如果有人对实现相同目标的更好方法有任何意见或想法，我当然有兴趣听听。话虽如此，到目前为止，我所拥有的一切都运行良好！

我最终得到的结果与@FaneDuru 和我上面讨论的有些不同。在研究如何改进我已有的东西时，我在不同的站点上遇到了另一个类似的线程，所以我根据我的情况修改了该代码，并且它工作得更顺利一些。

Link 上面提到： 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

制作一个可搜索的组合框来替换没有辅助列的数据验证

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

excel

vba

combobox

activex