Гиперссылка на книгу с возможностью просмотра в текущей книге?

[star282]

Товарищи, приветстывую Вас!
Вопрос такой, исторически сложилось что есть куча архивных книг (таблиц) и всегда есть текущая.
Работая в текущей часто нужно искать данные, которые быть может находятся или в текущей или в каком то из архивов =(
Приходится парралельно открывать все архивы по одному, и искать по Ctrl+F нужные данные.
Объеденить архивы в одну книгу нельзя! (историческая традиция учереждения)
А вот можно ли в текущей книге создать гиперссылки поиски на архивы (например на штук 5 книг?) чтобы работал поиск в том числе и по ним?
Грубо говоря сижу в текущей книге, нажимаю Ctrl+F  и ищется и в текущем и в архивных книгах на которых установлен "гиперссылочный поиск"? Далее нужная книга открывается и подсвечивается как обычно нужная строка. Ну или не открывается а на доп.листах текущей книги, "открыты" архивы с возможностью из просмотра.

[cheshiki1]

в нете висит такая заготовка.

Код Выделить Развернуть

Sub Поиск_во_всех_файлах()
Dim iShtName$, iPath$, iFileName$, firstAddress$
Dim iSheet As Worksheet, iFoundSht As Worksheet
Dim iTempWB As Workbook, iBazaWB As Workbook
Dim TextToFind As Variant, iFoundRng As Range
Dim FD As FileDialog, iLastRow&
Dim FoundAny As Boolean

    TextToFind = Application.InputBox("Введите текст для поиска:", "Поиск")
    If TextToFind = "" Or TextToFind = False Then Exit Sub
    TextToFind = Trim(TextToFind)
    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD
        .AllowMultiSelect = False
        .Title = "Укажите любой файл в папке"
        .ButtonName = "Выбрать папку"
        If .Show = False Then Exit Sub Else iPath = Mid(.SelectedItems(1), 1, InStrRev(.SelectedItems(1), "\"))
    End With
    Set FD = Nothing
    Workbooks.Add
    Sheets.Add.Name = "Поиск"
    Set iFoundSht = ActiveSheet
    iFoundSht.Cells(1, 1) = "Ищем: " & TextToFind
    iFoundSht.Cells(1, 1).Font.Bold = True
    With Application
        .ScreenUpdating = False
        .Calculation = xlManual
        .StatusBar = "Идёт поиск..."
        .ShowWindowsInTaskbar = False
        iFileName = Dir(iPath & "*.xls")
        Do While iFileName$ <> ""
            Set iTempWB = Workbooks.Open(Filename:=iPath & iFileName, UpdateLinks:=False, ReadOnly:=True)
            For Each iSheet In iTempWB.Sheets
                If iSheet.FilterMode = True Then iSheet.ShowAllData
                Set iFoundRng = iSheet.Cells.Find(What:=TextToFind, LookIn:=xlFormulas, LookAt:=xlPart)
                If Not iFoundRng Is Nothing Then
                    FoundAny = True
                    firstAddress = iFoundRng.Address
                    Do
                        With iFoundSht
                            iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                            If iLastRow = 1 Then iLastRow = 2
                            If iShtName <> iSheet.Name Then    'если новый файл
                                With .Cells(iLastRow + 2, 1)
                                    .Value = "Файл: " & iTempWB.Name & ", Лист: " & iSheet.Name
                                    .Font.Bold = True
                                End With
                            End If
                            iFoundRng.EntireRow.Copy Destination:=.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1)    'копируем всю строку
                            iShtName = iSheet.Name
                        End With
                        Set iFoundRng = iSheet.Cells.FindNext(iFoundRng)
                    Loop While iFoundRng.Address <> firstAddress
                Else
                End If
            Next
            iTempWB.Close SaveChanges:=False
            iFileName = Dir
        Loop
        .StatusBar = False
        .ShowWindowsInTaskbar = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    If FoundAny = False Then
        MsgBox "Текст '" & TextToFind & "' ни в одном из файлов в папке:" & Chr(10) & iPath & Chr(10) & " не был найден!", 48, "Отчёт"
        iFoundSht.Parent.Close SaveChanges:=False
        Exit Sub
    End If
    MsgBox "Поиск " & TextToFind & " завершён!", 64, "Поиск"
End Sub
посмотрите может подойдет.
запускаем макрос - всплывает окно какое слово ищем - в какой папке. После поиска на текущем листе печатаются все пути где было найдено слово.

[star282]

Спасибо, но боюсь это аналогично "стандартному щенку поисковику" работает по всем документам на дисках С и D?
Хочу именно ограничить и ускорить поиск "привязав" нужные книги в текущую.
Аналогию провожу с AutoCad - на чертеж можно вставить ссылку на другой чертеж, и второй чертеж будет виден на экране, и по нему работает поиск.
Вот бы в качестве этого "чертежа" в excel добавить тоже ссылку на нужные листы, но так чтобы их можно было видеть.