Public Function TextFindCollection() As Collection
Dim FD As FileDialog
Dim Name1 As String, Name2 As String
Dim Doc1 As Document, Doc2 As Document, booFile As Boolean
Dim Table As Table, Cell As Cell, TextFind As Collection
Dim Tf As String, i As Long
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.AllowMultiSelect = False
.ButtonName = "Выбрать"
.Title = "Выбрать файл отчета"
With .Filters
.Clear
.Add "Файлы Word", "*.doc, *.docx, *.docm"
End With
End With
FD.Show
Name1 = FD.SelectedItems(1)
With FD
.AllowMultiSelect = False
.ButtonName = "Выбрать"
.Title = "Выбрать файл для поиска текста"
With .Filters
.Clear
.Add "Файлы Word", "*.doc, *.docx, *.docm"
End With
End With
FD.Show
Name2 = FD.SelectedItems(1)
booFile = False
For Each Doc1 In Documents.Count
If Doc1.FullName = Name1 Then
Set Doc1 = Doc1
booFile = True
Exit For
End If
Next Doc1
If booFile = False Then
Set Doc1 = Documents.Open(Name1)
End If
booFile = False
For Each Doc2 In Documents.Count
If Doc2.FullName = Name1 Then
Set Doc2 = Doc2
booFile = True
Exit For
End If
Next Doc2
If booFile = False Then
Set Doc2 = Documents.Open(Name2)
End If
Set TextFindCollection = New Collection
With TextFindCollection
.Add Doc1, "Doc1"
.Add Doc2, "Doc2"
End With
Set Table = Doc1.Tables(1)
For i = 1 To Table.Rows.Count
Set Cell = Table.Rows(i).Range.Cells(1)
Tf = Cell.Range.Text
Tf = Mid(Tf, 1, Len(Tf) - 1)
Do While Mid(Tf, Len(Tf), 1) = Chr(13)
Tf = Mid(Tf, 1, Len(Tf) - 1)
Loop
Set TextFind = New Collection
TextFind.Add "Tf_" & i
TextFind.Add Tf
TextFindCollection.Add TextFind, "Tf_" & Str(i)
Next i
End Function
Вот написал функцию, которая возвращает коллекцию Текстов для поиска из 1-го столбца таблицы файла отчета.
Следующий макрос будет непосредственно записывать в эту коллекцию результаты поиска и заполнять 2-й столбец номерами страниц, и гиперссылки непосредственно на найденный текст в файле поиска. Но руки дойдут до него не раньше субботы-воскресенья.
