Расширение стандартного поиска. Как искать списки слов в Excel? - VBA

Формулировка задачи:

На входе задается список слов или фраз (например, через буфер обмена, или на отдельном листе). Макрос ищет вхождение любого слова на ВСЕХ листах открытой книги, и выводит итоговую таблицу (но новом листе или в диалоговом окне), где указаны имя листа, адрес ячейки, найденное значение. При клике переходим к ячейке, содержащей совпадение. Если какое-то слово нигде не найдено, то напротив него пишется "не найдено". Т.е. это тоже самое, что и стандартный поиск "CTRL+F", только задается не одно слово, а список слов (фраз). Я не смог изменить все найденные в инете решения под себя и реализовать такой скрипт, т.к. у меня очень небольшие знания VBA (знаю только простейшие операции копировать/вставить, условие, цикл). Итого. На входе: Список слов (фраз), каждая фраза с новой строки На выходе: 1. Таблица или диалоговое окно, которая содержит все исходные фразы и все найденные ядреса ячеек. Т.е. эквивалент стандартного окна CTRL+F; поиск по всей книге; кнопка "Найти все". 2. Эта таблица или диалоговое окно содержит ссылки на ячейки, где встретились совпадения (как и окно стандартного поиска, чтобы можно было перейти к конкретной ячейке на конкретном листе) 3. Для слов и фраз, для которых ничего не найдено, выводится "не найдено". Помогите мне, пожалуйста=)

Решение задачи: «Расширение стандартного поиска. Как искать списки слов в Excel?»

textual
                            Листинг программы 
                        
 
                            
                        
Option Explicit
Sub pr3()
    Dim sh As Worksheet, t$
    Dim lLastRow As Long, lLastCol As Long, LastRow As Long, r As Long, i As Long, j As Long
    Dim PathFileTxt As String
    Dim dic As Object
    Dim el As Variant
    Dim a
    
    Windows("искать тут.xlsm").Activate
      
    'альтернативный способ задать массив без открытия файла. не подходит для фраз, состоящих более чем из одного слова.
    'a = Split(CreateObject("Scripting.FileSystemObject").Getfile(ActiveWorkbook.Path & "\ИД.txt").OpenasTextStream(1).ReadAll, vbNewLine)
      
    'открываем файл с Исходными Данными
    PathFileTxt = ActiveWorkbook.Path & "\ИД.txt"
    Workbooks.OpenText Filename:=PathFileTxt, Origin:=1251
    Columns("A:A").Select
      
    'разбиваем по столбцам чтобы найти слова, а не фразы
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
      
      
    'удаляем пустые строки
    LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count    'определяем размеры таблицы
    Application.ScreenUpdating = False
    For r = LastRow To 1 Step -1           'проходим от последней строки до первой
        If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete   'если в строке пусто - удаляем ее
    Next r
        
      
    'определяем последнюю ячейку с данными
    With ActiveSheet.UsedRange: End With
    lLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    lLastCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
      
    'задаем массив исходных данных
    'a = [a1].CurrentRegion.Value       'ограничивает диапазон первой пустой строкой/столбцом, не подходит
    a = Range(Cells(1, 1), Cells(lLastRow, lLastCol)).Value
    ActiveWorkbook.Close False
      
    'создаем словарь с исходными данными для поиска
    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1
    With dic
        For Each el In a
            If el <> "" Then
             .Item(el) = ""
            End If
        Next
'        MsgBox "Список ключей для поиска:" & vbLf & vbLf & Join(.keys, vbLf)
    'ищем в словаре совпадения на наших листах
        For Each sh In Sheets
            'определяем последнюю ячейку с данными
            With sh.UsedRange: End With
            lLastRow = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
            lLastCol = sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1
            'задаем массив
            a = sh.Range(sh.Cells(1, 1), sh.Cells(lLastRow, lLastCol)).Value
            'a = [a1].CurrentRegion.Value       'ограничивает диапазон первой пустой строкой/столбцом
            'забиваем словарь адресами ячеек, в которых есть совпадения с ИД
            For i = 1 To UBound(a)
                For j = 1 To UBound(a, 2)
                    t = a(i, j)
'                    MsgBox "=ГИПЕРССЫЛКА(""[" & Application.ActiveWorkbook.FullName & "]" & sh.Name & "!""&АДРЕС(" & i & ";" & j & ");""" & sh.Name & "!""&АДРЕС(" & i & ";" & j & "))"
                    If .exists(t) Then .Item(t) = .Item(t) & IIf(.Item(t) = "", "", "|") & "=ГИПЕРССЫЛКА(""[" & Application.ActiveWorkbook.FullName & "]" & sh.Name & "!""&АДРЕС(" & i & ";" & j & ");""" & sh.Name & "!""&АДРЕС(" & i & ";" & j & ";4))"
                Next
            Next
              
        Next
          
'вытаскиваем из словаря ключи (keys) и их значения (items)
        Dim aK, aI, aSP, s As String, ss As String
        Dim lMaxC As Long, lc As Long
        aK = .keys
        aI = .items
        ReDim a(1 To .Count, 1 To 100)
        For i = 1 To .Count
            a(i, 1) = aK(i - 1)
            s = .Item((aK(i - 1)))
            If s <> "" Then
                aSP = Split(s, "|")
                lc = UBound(aSP) + 1
                If lMaxC < lc Then
                    lMaxC = lc
                End If
                For lc = LBound(aSP) To UBound(aSP)
                    ss = aSP(lc)
                    a(i, lc + 2) = ss
                Next
            End If
        Next
 
        'создаем новую книгу
        Workbooks.Add
 
        'вставляем данные на лист
        ActiveSheet.[a1].Resize(.Count, lMaxC + 1).FormulaLocal = a
         
        Columns("B:XFD").EntireColumn.AutoFit
        Range("A1").Activate
        Application.ScreenUpdating = True
'        MsgBox "Done!"
'        ActiveWorkbook.Close False
    End With
 End Sub