質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
87.20%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

解決済

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

shibakoppe
shibakoppe

総合スコア27

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

1回答

0評価

0クリップ

371閲覧

投稿2022/06/08 01:47

編集2022/06/08 14:24

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

いろいろ調べてみたところ「サブフォルダ含むすべてのフォルダの 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ではなく、この部分だけ他の変数を用いる等をすればよいのでしょうか…?

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

良い質問の評価を上げる

以下のような質問は評価を上げましょう

  • 質問内容が明確
  • 自分も答えを知りたい
  • 質問者以外のユーザにも役立つ

評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

気になる質問をクリップする

クリップした質問は、後からいつでもマイページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

  • プログラミングに関係のない質問
  • やってほしいことだけを記載した丸投げの質問
  • 問題・課題が含まれていない質問
  • 意図的に内容が抹消された質問
  • 過去に投稿した質問と同じ内容の質問
  • 広告と受け取られるような投稿

評価を下げると、トップページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

まだ回答がついていません

会員登録して回答してみよう

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
87.20%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問

同じタグがついた質問を見る

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。