FIND (Найти все)

[Tecos]

Добрый день, знатоки VBA. Помогите, пожалйста мне с решением следующего вопроса:
Необходимо провести поиск по базе данных (лист excell) и все значения, удовлетворяющие условиям поиска поместить в список на главной странице.

Проблема в том, что приведенный ниже код, выбирает только первую, подходящую условиям запись и прекращает свое действие. Что добавить в код, чтобы в список попадали все значения, удовлетворяющие поиску?

Код: Выделить всё

Private Sub CommandButton1_Click()
usl = Sheets("INDEX").TextBox1.Value
Dim rng As Range
Sheets("INDEX").ListBox1.Clear
Set rng = Sheets("BAZA").Range("A1:A65000").Find(What:=usl, LookIn:=xlValues)
If Not (rng Is Nothing) Then
i = Mid(rng.Address, 4)
        kateg = Sheets("BAZA").Cells(i, 1).Value
        vid = Sheets("BAZA").Cells(i, 2).Value
        If kateg <> "" Then Sheets("INDEX").ListBox1.AddItem kateg & " " & vid
     Else
     MsgBox "Значение не найдено!"
     End If
End Sub

Прилиагаю файл с указанным кодом. То есть при условии поиска "фрукт" в список была добавлена строка не только
фрукт абрикос
А все возможные значения:
фрукт яблоко
фрукт абрикос
фрукт апельсин
фрукт персик

Заранее благодарен. Код мне нужен для работы.

[Viper]

Метод Find и должен возвращать первую найденную ячейку, чтобы найти и другие ячейки, удовлетворяющие критерию поиска, надо воспользоваться методом FindNext. Т.е. первая ячейка ищется методом Find, а далее вызывается метод FindNext до тех пор, пока он не вернет Nothing.
З.Ы. По VBA не специалист, посему предполагаю, что есть более простой способ найти все нужное.

[KL]

Код: Выделить всё

Private Sub CommandButton1_Click()
    Dim rng As Range        'Search range
    Dim rngMatch As Range   'Current match range
    Dim cnt As Long         'Counter
    Dim usl As String       'Match pattern
    Dim i As Long
   
    Set rng = Sheets("BAZA").Range("A:A")
    usl = "*" & Sheets("INDEX").TextBox1.Value & "*"
   
    Application.ScreenUpdating = False
    On Error Resume Next
   
    'Check for matches
    cnt = Application.CountIf(rng, usl)
    If cnt = 0 Then
        MsgBox "Значение не найдено!"
        Exit Sub
    End If
   
    'Find the first match
    Set rngMatch = rng.Find(usl, rng(1), xlValues, xlWhole)
    Sheets("INDEX").ListBox1.AddItem rngMatch & " " & rngMatch.Offset(, 1)
   
    'Loop through the rest of matches
    For i = 1 To cnt - 1
        Set rngMatch = rng.Find(usl, rngMatch, xlValues, xlWhole)
        Sheets("INDEX").ListBox1.AddItem rngMatch & " " & rngMatch.Offset(, 1)
    Next i
    Application.ScreenUpdating = True
End Sub

[Tecos]

KL, спасибо большое, воспользовался Вашим кодом!