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

Question

我正在为人员配备目的建立一个电子表格。包含它的工作簿由 2 张纸组成。有问题的一个和一个单独的用于各种不同情况的验证列表。目前没有一个是相互依赖的。有问题的两个列表是针对团队成员和角色的。它们都在单独的结构化表中，并且都包含在双命名范围中。第一个直接引用表列，第二个引用第一个以使其间接引用表。
我的目标是在不使用辅助列的情况下使组合框可搜索。我有这个，它有点工作，但因为公式是不稳定的，它很容易坏掉。我找到并适应了我的代码的第一部分以满足我的需要。但基本上，它使组合框出现在任何为下拉设置数据验证并为其设置一些参数的单元格中。我关闭了验证下拉菜单以适应组合框，它运行良好。我似乎无法得到的部分是“可搜索的部分”。在 TempCombo_Keydown sub 我尝试将命名范围放在数组中并循环遍历它们，以使组合框仅返回包含键入的字符串的名称，无论它们在名称中的哪个位置。长话短说，我遇到了无数错误，例如类型不匹配、权限被拒绝和其他一些错误，每次我认为我已经修复了一个错误时，都会弹出... *注意 - 所有表格都是结构化的表
我绝不是 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 和我上面讨论的有点不同的东西。在研究如何改进我已经拥有的东西时，我在另一个站点上遇到了另一个类似的线程，所以我根据我的情况修改了那个代码，它工作起来更顺利一点。
上面提到的链接:
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