Расширение стандартного поиска. Как искать списки слов в 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
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д