Функция поиска - прошу проанализировать

[jimmyyong]

Друзья, добрый день!

Прошу проанализировать мою функцию поиска. Насколько верно написан код?

При вызове функции ей передается массив с ключевыми словами, которые она будет искать в Excel-вском файле на активном листе. Если все слова из массива найдены в какой-либо ячейке, то функция возвращает адрес найденной ячейки (если результат найден один). Если результат не один, то возвращается соответствующее значений

Function Поиск_1(Массив)

'Определение типа данных
Dim x As Range
Dim ADR_1$, ADR_2$ 'Var$, Var1$, Var2$
Dim Найдено%, Ищем_дальше%, Кол_во%

'Определяем количество ненулевых элементов
'Выбираем первый элемент массива
For Each Var In Массив
    If Len(Var) > 0 Then
    
        If Len(Var1) = 0 Then Var1 = Var
        Кол_во = Кол_во + 1
    
    End If
Next Var

    With ActiveSheet.UsedRange
        Set x = .Find(What:=Var1, LookAt:=xlPart, MatchCase:=False)
        If Not x Is Nothing Then
           
           'Адрес первой найденной ячейки
            ADR_1 = x.Address
                   'Цикл поиска
                    Do
                            
                            Найдено = 0
                            
                            'Перебираем все слова
                            For Each Var2 In Массив
                                If Len(Var2) > 0 And Var2 <> Var1 Then
                                    If InStr(1, Trim(x.Value), Var2, vbTextCompare) Then
                                        Найдено = Найдено + 1
                                            If Найдено = Кол_во - 1 Then
                                            'MsgBox x.Address
                                            End If
                                    End If
                                End If
                            Next Var2
                
                            'Ищем дальше
                             Set x = .FindNext(x)
                             ADR_2 = x.Address
                             Ищем_дальше = 1 + Ищем_дальше
             
                Loop While ADR_2 <> ADR_1
            
        End If
    End With
 
If Ищем_дальше > 1 Then Поиск_1 = "Несколько значений"
If Ищем_дальше = 1 Then Поиск_1 = x.Address
If Ищем_дальше = 0 Then Поиск_1 = "Не найдено"

End Function

[Hugo121]

Сообщение от jimmyyong

Если все слова из массива найдены в какой-либо ячейке

Вот тут думаю нужно либо разбивать найденное в массив и проверять массив, удаляя найденное слово, или удалять заменой из строки. Иначе в одном слове qwertyu найдутся все слова из списка qwe, ert, tyu.
Хотя конечно может в реальной задаче такого никогда не будет - но нам она неизвестна.

[jimmyyong]

Hugo понимаю о чем вы говорите, но я формирую "массив поиска" из слов у которых исключены окончания, не более. И держу в голове возможное "пересечения" слов.

Допустим, мне нужно найти адрес заголовка "Примерный текст заголовка №34 - Название". В этом случае у меня массив будет сформирован из элементов: "Пример", "текст", "заголов".

[Skif-F]

Сообщение от jimmyyong

If Ищем_дальше > 1 Then Поиск_1 = "Несколько значений"
If Ищем_дальше = 1 Then Поиск_1 = x.Address
If Ищем_дальше = 0 Then Поиск_1 = "Не найдено"

Не интересно, лучше, когда возвращается диапазон (Range) или массив диапазонов или Nothing, если ничего не найдено:

function Поиск_1(Массив) as Variant  'можно Range в зависимости от реализации
...
If Ищем_дальше > 1 Then Поиск_1 = МассивНайденныхЭлементов
If Ищем_дальше = 1 Then set Поиск_1 = x
If Ищем_дальше = 0 Then set Поиск_1 = Nothing

[Skif-F]

Вот как-то так:

Function Поиск_1(Массив As Variant) As Range
    'Определение типа данных
    Dim x As Range
    Dim FirstAdr As String, ЗначениеЦикла As Variant, ПервыйЭлемент As String
    Dim Найдено As Integer, Совпадений As Integer, Кол_во As Integer
    Dim МассивПоиска() As String, МассивАдресов() As String

    'Выкидываем пустые элементы
    For Each ЗначениеЦикла In Массив
        If Len(ЗначениеЦикла) > 0 Then
            If Len(ПервыйЭлемент) = 0 Then
                ПервыйЭлемент = ЗначениеЦикла 'Выбираем первый элемент массива
            Else
                ReDim Preserve МассивПоиска(Кол_во)
                МассивПоиска(Кол_во) = ЗначениеЦикла
                Кол_во = Кол_во + 1
            End If
        End If
    Next ЗначениеЦикла
    'Поиск
    With ActiveSheet.UsedRange
        Set x = .Find(What:=ПервыйЭлемент, LookAt:=xlPart, MatchCase:=False)
        If Not x Is Nothing Then
            FirstAdr = x.Address 'Адрес первой найденной ячейки
            'Цикл поиска
            Do
               Совпадений = 0
               'Перебираем все слова
               For Each ЗначениеЦикла In МассивПоиска
                    'По применению функции Trim() можно поспорить.
                    'Иногда надо найти именно " что-то " с пробелом до или после
                    If InStr(1, Trim(x.Value), ЗначениеЦикла, vbTextCompare) Then
                        Совпадений = Совпадений + 1
                        If Совпадений = Кол_во Then
                            ReDim Preserve МассивАдресов(Найдено)
                            МассивАдресов(Найдено) = x.Address
                            Найдено = Найдено + 1
                        End If
                    End If
               Next ЗначениеЦикла
               Set x = .FindNext(x) 'Ищем дальше
            Loop While FirstAdr <> x.Address
        End If
    End With
    'Формирование результата
    If Найдено > 1 Then
        Set Поиск_1 = Range(Join(МассивАдресов, ","))
    ElseIf Найдено = 1 Then
        Set Поиск_1 = Range(МассивАдресов(0))
    Else
        Set Поиск_1 = Nothing
    End If
End Function