Может этот код поможетб у меня оно работает.
ну а диапазоны в макросе надо задать самому, этот макрос пивязан к кнопке, при нажатии выводится окно где надо ввести нужое слово.

Public Sub find()
Dim rng As Range
Dim dd(1 To 50) As String
Dim ss As String
Dim sstr As String
ff = InputBox("Для поиска введите слово или часть слова")
Range("a10:c20").Select
Selection.ClearContents

sstr = "*" & ff & "*"
i = 0
j = 0

Set rng = Range("b1:b7") // диапазон где находятся данные для филтрации

For Each rng In rng
j = j + 1
If rng.Value Like sstr Then
' Debug.Print rng.Value
' MsgBox (rng.Value)
i = i + 1
dd(i) = rng.Value
ss = rng.Value
' Sum = Sum + Sheets("sheet1").Cells(j, 4)
End If
Next rng
end sub

Ну желаю удачи!

Можно, но пожже, (надо макрос переписать а то что я прислал не то делает что вам надо) OK?

Вот и пример!
Код Макроса -
Public Sub find()
Dim rng As Range
Dim dd(1 To 50) As String
Dim ss As String
'Dim sstr As String
ff = InputBox("Äëÿ ôèëòðàöèè íàçâàíèè ââåäèòå íóæíîå íàçâàíèå, àëè ÷àñòü íàçâàíèÿ")
Range("a10:c20").Select
Selection.ClearContents
ff = Left(ff, 1)
sstr = "*" & ff & "*"

i = 0
j = 0
Sum = 0
Set rng = Range("b1:b10")

For Each rng In rng
j = j + 1
If Left(rng.Value, 1) Like sstr Then
' Debug.Print rng.Value
' MsgBox (rng.Value)
i = i + 1
dd(i) = rng.Value
' ss = rng.Value
'Sum = Sum + Sheets("sheet1").Cells(j, 4)
End If
Next rng
Sheets("sheet1").Cells(14, 2) = "Íàéäåíî -"
Sheets("sheet1").Cells(14, 3) = i
'Sheets("sheet1").Cells(11, 2) = ss
For k = 1 To i
Sheets("sheet1").Cells(14 + k, 1) = k
Sheets("sheet1").Cells(14 + k, 2) = dd(k)
Next k
'Sheets("sheet1").Cells(11, 3) = Sum
End Sub

Что то фаил с примером не цепляется, я высиляю пример емаилом! ОК?

извените ещё один деталь надо в if-e вместо Left(rng.Value,1) поставить (rng.Value) OK!? :)