Предложение автозаполнения в списке проверки данных Excel снова

Question

Как вносить предложения в список проверки данных Excel при наборе текста. В моем запросе есть ограничения:

1. Список предметов должен быть на другом листе и не должен быть выше в скрытых строках.
2. Ввод фразы должен сузить список до всех пунктов, которые содержат фразу.
3. Поиск должен выполняться без учета регистра.

Таким образом, после ввода am мы должны предположить гипотетическое предложение выбрать из Amelia, Camila, Samantha, при условии, что имена этих девушек есть в списке предметов.

Я нашел хорошее решение здесь , однако оно не фильтрует элементы с предложением contains, а begins with. Здесь я кратко изложу предложенное решение.

1. Вставляем поле со списком (элемент управления ActiveX) на лист.

2. Щелкните правой кнопкой мыши имя листа> Показать код> и вставьте код VBA в редактор VBA листа:

   Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   'Update by Extendoffice: 2018/9/21
       Dim xCombox As OLEObject
       Dim xStr As String
       Dim xWs As Worksheet
       Dim xArr
       Set xWs = Application.ActiveSheet
       On Error Resume Next
       Set xCombox = xWs.OLEObjects("TempCombo")
       With xCombox
           .ListFillRange = ""
           .LinkedCell = ""
           .Visible = False
       End With
       If Target.Validation.Type = 3 Then
           Target.Validation.InCellDropdown = False
           Cancel = True
           xStr = Target.Validation.Formula1
           xStr = Right(xStr, Len(xStr) - 1)
           If xStr = "" Then Exit Sub
           With xCombox
               .Visible = True
               .Left = Target.Left
               .Top = Target.Top
               .Width = Target.Width + 5
               .Height = Target.Height + 5
               .ListFillRange = xStr
               If .ListFillRange = "" Then
                   xArr = Split(xStr, ",")
                   Me.TempCombo.List = xArr
               End If
               .LinkedCell = Target.Address
           End With
           xCombox.Activate
           Me.TempCombo.DropDown
       End If
   End Sub
   
   Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
       Select Case KeyCode
           Case 9
               Application.ActiveCell.Offset(0, 1).Activate
           Case 13
               Application.ActiveCell.Offset(1, 0).Activate
       End Select
   End Sub
   

Я не смог найти способ изменить параметр поиска с «начинается с» на contains.

До сих пор задавались вопросы об автозаполнении или автозаполнении в списке проверки.
Проверка данных Excel с предложениями / автозаполнение
Excel 2010: как использовать автозаполнение в списке проверки
Но ни один из них не содержал ответов, которые бы удовлетворяли наложенным мною ограничениям.

Тестовый файл для скачивания здесь .

Answer 1

Чтобы преодолеть ваше первое ограничение, возможно, вы можете назначить диапазон для вашего поля со списком:

Dim xCombox             As OLEObject
    Dim xStr                As String
    Dim xWs                 As Worksheet
    Dim xArr
    Dim i                   As Range

    Set xWs = Application.ActiveSheet
    On Error Resume Next
    Set xCombox = xWs.OLEObjects("Combotest")
    With Sheets("Test_list2")
    Set i = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    Combotest.ListFillRange = i.Address
 Set xWs = Application.ActiveSheet
    On Error Resume Next
    Set xCombox = xWs.OLEObjects("Combotest")
    With xCombox
        .LinkedCell = "F2"
        .Visible = True
    End With
.
.
.
.
End Sub

Answer 2

Попробуйте добавить следующее событие (дополнительно другое 2). Каждый раз, когда вы что-то вводите, код обновляет список ComboBox.

Private Sub TempCombo_Change()
    With Me.TempCombo
        If Not .Visible Then Exit Sub
        .Clear 'needs property MatchEntry set to 2 - fmMatchEntryNone
        .Visible = False 'to refresh the drop down
        .Visible = True
        .Activate
        Dim xStr As String, xArr As Variant
        xStr = TempCombo.TopLeftCell.Validation.Formula1
        xStr = Right(xStr, Len(xStr) - 1)
        xArr = Split(xStr, Application.International(xlListSeparator))
        Dim itm As Variant
        For Each itm In xArr
            If InStr(1, itm, .Value, vbTextCompare) > 0 Or .Value = "" Then
                .AddItem itm
            End If
        Next itm
        .DropDown
    End With
End Sub