Список с макросом

[and150382]

Помогите пожалуйста!
Нужно добавить в макрос функцию поиска по первым буквам. Чтобы я начал набирать фамилию, а она сортировалась в списке. Потом после выбора фамилии она добавлялась в ячейку. Список будет большой.Макрос у меня в колонке H, а мне нужно еще в колонки J , R , V . Помогите пожалуйста, уже неделю сижу и ничего не получается.

[slan]

вот одна из моих разработок:

на листе форма заполняется анкета, напротив некот ячеек, например, фамилия - выскакивает окно списка, в котором реализован необходимый вам алгоритм. его можно реализовать и для списка проверки данных с некот ограничениями.

на листе справочники - источники для списков.

попробуйте разобраться, хотя это и не совсем просто - писалось не для образовательных целей, комментариев нету.

[slan]

ps
при выделении ячейки запускается программа получения списка с листа справочники:

Function getlist(s$) As Boolean
    On Error Resume Next
    Dim n&
    With Sheets("Справочники")
        n = Application.Match(Replace(s, "__англ__", ""), .Rows(1), 0)
        If n = 0 Then Exit Function
        lst = .Range(.Cells(2, n), .Cells(65000, n).End(xlUp))
        
    End With
    If lst(0) <> "" Then getlist = True
End Function

загружается нужный исходник списка в глобально объявленный массив lst

при наборе букв в листбоксе, список начинает фильтроваться:

Sub filt(cb As MSForms.ComboBox)
    s = cb.Text
    If s = "" Then Exit Sub
    Dim w, x, n&, ar, nf&
    ar = Split(Application.Trim(s), " ")
    ReDim rez(1 To UBound(lst))
    For Each w In lst
        nf = -1
        For Each x In ar
            If InStr(1, UCase(w), UCase(x)) > 0 Then
                nf = nf + 1
            End If
        Next
        If nf = UBound(ar) Then
            n = n + 1
            rez(n) = w
        End If
    Next
    If n > 0 Then
        ReDim Preserve rez(1 To n)
    Else
        ReDim rez(1 To 1)
        rez(1) = ""
    End If
    prog = True
    With cb
        .List = rez
        .DropDown
    End With
    prog = False
End Sub

фильтрованный список переписывается в массив rez( и затем передается в листбокс). . здесь реализован алгоритм поиска набора ключевых слов, разделенных пробелами - из списка выбираются значения, содержащие хотя бы одно из ключевых слов( не слов в буквальном понятии, а набора знаков - например, может быть одна буква или пара, а через пробел еще пара, это уже другое "ключевое слово"). легко можно изменить на поиск содержащих все ключевые слова одновременно или не содержащих, а начинающихся на нужную комбинацию..

при очень больших списках можно с каждой набранной буквой фильровать не с исходного массива lst? а уже отфильтрованный rez, который будет становиться все короче и короче. при огромных списках я их индексировал и начинал фильтровать только начиная с ввода не мене 3х символов..

[and150382]

В необходимые столбцы добавил. А вот как сделать поиск незнаю.
Вот что у меня получилось


Private Sub Worksheet_Change(ByVal Target As Range)

Dim lReply As Long, i As Integer
Dim counter As Integer, MyName As String, NameRange As String

If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = "8" Then
If IsEmpty(Target) Then Exit Sub
counter = Len(Target)
MyName = Left(Target, counter)
For i = 1 To Range("People").Count
NameRange = Left(Range("People").Cells(i), counter)
If LCase(NameRange) = LCase(MyName) Then
Application.EnableEvents = False
Application.EnableEvents = True
Exit For
End If
Next
If WorksheetFunction.CountIf(Range("Pe ople"), Target) = 0 Then
lReply = MsgBox("Добавить введенное имя " & _
Target & " в выпадающий список?", vbYesNo + vbQuestion)
If lReply = vbYes Then
Range("People").Cells(Range("People ").Rows.Count + 1, 1) = Target
Range("People").Resize(Range("Peopl e").Rows.Count + 1).Name = "People"
Range("People").Sort Key1:=Range("AD12"), _
Order1:=xlAscending, Header:=xlNo
Else
Target = ""
End If
End If
End If

If Target.Column = "10" Then
If IsEmpty(Target) Then Exit Sub
counter = Len(Target)
MyName = Left(Target, counter)
For i = 1 To Range("People").Count
NameRange = Left(Range("People").Cells(i), counter)
If LCase(NameRange) = LCase(MyName) Then
Application.EnableEvents = False
Application.EnableEvents = True
Exit For
End If
Next
If WorksheetFunction.CountIf(Range("Pe ople"), Target) = 0 Then
lReply = MsgBox("Добавить введенное имя " & _
Target & " в выпадающий список?", vbYesNo + vbQuestion)
If lReply = vbYes Then
Range("People").Cells(Range("People ").Rows.Count + 1, 1) = Target
Range("People").Resize(Range("Peopl e").Rows.Count + 1).Name = "People"
Range("People").Sort Key1:=Range("AD12"), _
Order1:=xlAscending, Header:=xlNo
Else
Target = ""
End If
End If
End If

If Target.Column = "18" Then
If IsEmpty(Target) Then Exit Sub
counter = Len(Target)
MyName = Left(Target, counter)
For i = 1 To Range("People").Count
NameRange = Left(Range("People").Cells(i), counter)
If LCase(NameRange) = LCase(MyName) Then
Application.EnableEvents = False
Application.EnableEvents = True
Exit For
End If
Next
If WorksheetFunction.CountIf(Range("Pe ople"), Target) = 0 Then
lReply = MsgBox("Добавить введенное имя " & _
Target & " в выпадающий список?", vbYesNo + vbQuestion)
If lReply = vbYes Then
Range("People").Cells(Range("People ").Rows.Count + 1, 1) = Target
Range("People").Resize(Range("Peopl e").Rows.Count + 1).Name = "People"
Range("People").Sort Key1:=Range("AD12"), _
Order1:=xlAscending, Header:=xlNo
Else
Target = ""
End If
End If
End If

If Target.Column = "22" Then
If IsEmpty(Target) Then Exit Sub
counter = Len(Target)
MyName = Left(Target, counter)
For i = 1 To Range("People").Count
NameRange = Left(Range("People").Cells(i), counter)
If LCase(NameRange) = LCase(MyName) Then
Application.EnableEvents = False
Application.EnableEvents = True
Exit For
End If
Next
If WorksheetFunction.CountIf(Range("Pe ople"), Target) = 0 Then
lReply = MsgBox("Добавить введенное имя " & _
Target & " в выпадающий список?", vbYesNo + vbQuestion)
If lReply = vbYes Then
Range("People").Cells(Range("People ").Rows.Count + 1, 1) = Target
Range("People").Resize(Range("Peopl e").Rows.Count + 1).Name = "People"
Range("People").Sort Key1:=Range("AD12"), _
Order1:=xlAscending, Header:=xlNo
Else
Target = ""
End If
End If
End If
End Sub

Может кто знает?