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

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

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

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

  1. Вставляем Combo Box (ActiveX Control) на лист.
  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: как использовать автозаполнение в списке проверки
Но ни один из них не содержал ответов, которые удовлетворяли бы наложенным мною ограничениям.

Тестовый файл для загрузки находится здесь.

0
Przemyslaw Remin 11 Янв 2019 в 13:04

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
1
Pᴇʜ 11 Янв 2019 в 14:18

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

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
0
P. Mehta 9 Апр 2019 в 10:39