VBA　フォルダ内の全ファイルに文字列検索をし、該当するセルへのハイパーリンクを設定したい

いつも大変お世話になっております。
複数あるマスターデータに対して、必要データを抽出するために、フォルダ内の全ファイルに対して文字列検索を行い、さらに、該当のデータが記載されているセルへのハイパーリンクを設定し、作業を効率よく進められるようなマクロを組みたいと考えております。

いろいろ調べてみたところ「サブフォルダ含むすべてのフォルダの Excel を文字検索するマクロ！」というサイトに出会い、利用させていただくことで、文字列の検索という前提はクリアできました。
しかし、その後のハイパーリンクの設定で作業が難航しております。
以下、コードを記載いたします。

'=================================================================================
' フォルダ（サブフォルダ含む）内の Excel ブックの文字を検索するマクロ
'=================================================================================

Const SEARCH_WORD = "\*.xls*"
Const SHEET_OUTPUT = "search"
Const CELL_PRINT_COL = 1
Const CELL_PRINT_ROW = 6
Const CELL_SEARCH_WORD = "B3"

Dim nowRow As Long


' メイン処理
Sub searchMacro()

    Dim buf As String
    Dim Path As String
    Dim myBook As Workbook
    nowRow = CELL_PRINT_ROW
    Set myBook = ThisWorkbook
    
    If Range(CELL_SEARCH_WORD) <> "" Then
            
        Path = getFolderName()
        
        Call reset
        
        Call searchFile(Path, myBook)
        
        If nowRow = CELL_PRINT_ROW Then
            
            MsgBox "検索結果：「" & Range(CELL_SEARCH_WORD) & "」が含まれるファイルはありませんでした。"
            
        Else
        
            MsgBox "検索結果：「" & Range(CELL_SEARCH_WORD) & "」が含まれるファイルが" & nowRow - CELL_PRINT_ROW & "件ヒットしました！"
                
        End If
        
    
    Else
    
        MsgBox "検索ワードを入力してください"
    
    End If
    
End Sub


' 再帰的にファイルを検索
Private Sub searchFile(ByVal Path As String, ByRef myBook As Workbook)

    On Error Resume Next

    Dim buf As String, f As Object
    buf = Dir(Path & SEARCH_WORD)
    
    searchWord = Range(CELL_SEARCH_WORD)
        
    Do While buf <> ""
        
        Call grepExcel(searchWord, myBook, Path, buf)
        buf = Dir()
        
    Loop
    
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(Path).SubFolders
            Call searchFile(f.Path, myBook)
        Next f
    End With

End Sub


' ダイアログでフォルダ名取得
Private Function getFolderName()

    Dim folderPath As Variant
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = 0 Then
            End
        End If
        folderPath = .SelectedItems(1)
    End With
    
    getFolderName = folderPath
  
End Function


' Excel ファイル内の文字検索
Private Sub grepExcel(ByVal searchWord, ByRef myBook As Workbook, ByVal Path As String, ByVal buf As String)

    Dim filePath
    Dim wb As Workbook
    Dim readSheet As Worksheet
    Dim Rng As Range
    Dim findResult

    fullPath = Path & "\" & buf

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Set wb = Workbooks.Open(Filename:=fullPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True, Password:="")
    
    If Err.Number = 1004 Then
        
        Err.Clear
    
    Else
    
        For Each mysheet In wb.Worksheets
            
            Set findResult = mysheet.Cells.Find(searchWord, LookAt:=xlPart)
            Dim findCell As Range
            Set findCell = findResult
            
            If Not (findCell Is Nothing) And Not (findResult Is Nothing) Then
            
                Do
                    If Not (findCell Is Nothing) And Not (findResult Is Nothing) Then
                        Call writeSheet(myBook, Path, buf, mysheet, findCell)
                        Set findCell = mysheet.Cells.FindNext(findCell)
                        If findCell Is Nothing Then
                            Exit For
                        End If
                    Else
                        Exit For
                    End If
                Loop While findCell.Row <> findResult.Row
                    
            End If
            
        Next

    End If

    wb.Close savechanges:=False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub


' 検索結果を出力
Private Sub writeSheet(ByRef myBook As Workbook, _
                        ByVal Path As String, _
                        ByVal buf As String, _
                        ByRef mysheet, _
                        ByRef findCell As Range)

    Dim outputSheet
    Dim outputCell
    
    Set outputSheet = myBook.Worksheets(SHEET_OUTPUT)
    
    outputCell = Split(Columns(findCell.Column).Address, "$")(2) & findCell.Row
    
    If outputCell <> "" Then
        
        outputSheet.Cells(nowRow, CELL_PRINT_COL) = buf
        outputSheet.Cells(nowRow, CELL_PRINT_COL + 1) = Path
        outputSheet.Cells(nowRow, CELL_PRINT_COL + 2) = mysheet.Name
        outputSheet.Cells(nowRow, CELL_PRINT_COL + 3) = outputCell
        nowRow = nowRow + 1
    
    End If

End Sub

上記コードによって抽出されたフルパスに対してハイパーリンクを設定するために、次のコードを用いました。


Sub ハイパーリンクの設定()

  Dim i As Long
  
  With ActiveSheet
        For i = 6 To 1000
        If Cells(i, 5).Value = "" Then
        '別ブックへの、ハイパーリンクの設定
        .Hyperlinks.Add anchor:=.Cells(i, 5), _
                        Address:=.Cells(i, 8)

        End If
        Next i
    End With

End Sub

さらに検索マクロで抽出された該当セルをSubAddressとして指定したいのですが、確定された文字列ではないので変数を用いたいと考えたのですが、この点で悩んでおります。
初心者の考えで恐縮ですが、SubAddressでもCellsを使用する方法はありますでしょうか？

毎度のことながらご迷惑をおかけしてしまい申し訳ございませんが、今一度皆様のお力をお貸しいただきたく思います。
何卒宜しくお願い申し上げます。

※追記1※
投稿時に記載しそびれてしまったのですが、最終的にセルの指定まで出来たらハイパーリンクの文字列を短縮表示したいと考えております。
TextToDisplayをしようすると文字列のみの使用となってしまうと思うのですが、こちらもCellsを使用するといった方法を取ることはできますでしょうか？

お手数をおかけしますが、こちらについても併せてご教示いただけますと幸いです。
何卒宜しくお願い申し上げます。

※追記2※
hatena19様にご教示いただいた以下のコードを試したところ

.Hyperlinks.Add anchor:=.Cells(i, 5), _
Address:=.Cells(i, 8), _
SubAddress:="'" & .Cells(i, 3) & "'!" & .Cells(i, 4) , _
TextToDisplay:=.Cells(i, 7) 'G列に短縮表示文字があると仮定

上記のTextToDisplay:=.Cells(i, 7) の部分で実行エラー5(プロシージャの呼び出し、または引数が不正)が起きてしまっているようなのですが、変数iではなく、この部分だけ他の変数を用いる等をすればよいのでしょうか…？

何度も申し訳ございません。

行動規範の内容に同意します

回答1件

ベストアンサー

SubAddressの指定は、'シート名'!A1 というような書式になりますので、そのような文字列になるように&演算子で連結すればいいでしょう。
「ハイパーリンクの文字列を短縮表示したい」とのことですが、どのように短縮したいのが不明ですが、上記と同様にご希望の文字列になるように加工してください。(わからない場合は具体的にどう短縮したいか説明してください。)

vba
1Sub ハイパーリンクの設定()
2
3  Dim i As Long
4  
5  With ActiveSheet
6        For i = 6 To .Cells(Rows.Count, 1).End(xlUp).Row
7        If Cells(i, 5).Value = "" Then
8        '別ブックへの、ハイパーリンクの設定
9        .Hyperlinks.Add anchor:=.Cells(i, 5), _
10                        Address:=.Cells(i, 8), _
11                        SubAddress:="'" & .Cells(i, 3) & "'!" & .Cells(i, 4) , _
12                        TextToDisplay:=.Cells(i, 7) 'G列に短縮表示文字があると仮定
13        End If
14        Next i
15    End With
16
17End Sub

投稿2022/06/08 02:48

hatena19

総合スコア33715

shibakoppe

2022/06/08 05:13 編集

お世話になります。いつもお力添えをいただき、誠にありがとうございます。早速ご教示いただいた構文を試してみたのですが、 .Hyperlinks.Add anchor:=.Cells(i, 5), _ Address:=.Cells(i, 8), _ SubAddress:="'" & .Cells(i, 3) & "'!" & .Cells(i, 4) , _ TextToDisplay:=.Cells(i, 7) 'G列に短縮表示文字があると仮定上記の部分で「実行時エラー5　プロシージャの呼び出し、または引数が不正」となってしまいました。この場合、iについての宣言を修正すればよいのでしょうか…？

shibakoppe

2022/06/08 05:23 編集

どうやら該当箇所はTextToDisplay:=.Cells(i, 7)この部分のようです…。

shibakoppe

2022/06/08 05:24

度々申し訳ございません。 TextToDisplay:=.Cells(i, 7).Valueとしたら上手くいきました！お騒がせいたしました…

hiroshiman

2023/05/29 18:03

この件、自分もハマっています。まったく同じ作業をしようとしていると思うのですが、 TextToDisplay:=.Cells(i, 7).Value　としただけでは動かないです。ほかに修正すべき箇所があるのでしょうか。

hatena19

2023/05/30 00:42

それだけの情報では原因を特定するのは難しいので、別に質問を立ちあげて、そこで、どのようなことをしたくて、どのようなコードを書いて、どのように動かないのか、詳細な情報を提示してください。

hiroshiman

2023/05/31 00:08

全く同じことをしようとしているだけですけど、別に質問を立ち上げたほうがいいでしょうか。

hatena19

2023/05/31 01:44

全く同じことをしているなら、この質問者さんや私のサンプルでは動いているので、そちらでも動くはずです。動かないということは、どこかが違うということです。それを特定するためには、それなりの情報が必要です。すくなくとも現象を再現できるコードとシートの状況が必要です。このコメント欄では使いづらいし、新規だと、私以外の他の人の回答を得られる可能性が高いです。

hiroshiman

2023/05/31 07:33 編集

もう一度コードを確認して、間違いに気づけなかったら、別の質問を立ち上げます。このやりとりで、過去コメントが検索結果から見えなくなってしまったので、自分のコメントは全部消そうと思います。

行動規範の内容に同意します