VBA フォルダ内の全エクセルファイルの文字列検索マクロ | ブイサバ【Excel VBAサバイバル】～とりあえずここに来れば解決できる～

任意の文字列がどのエクセルファイルに存在するのかを調査するVBAマクロを紹介します。

フォルダ内の全エクセルファイルの文字列検索マクロの仕様

指定フォルダ内に存在する全エクセルファイルを調査し、任意の文字列が含まれているか調査します。

もし、エクセルファイル内に指定する文字列が存在すれは、該当するファイル名の一覧及び、ファイルへのハイパーリンクを表示します。

任意の文字列はインプットボックスで入力します。

文字列は２つ指定でき、AND検索を実施します。

また、エクセルファイルにパスワードがかかっているなど、ファイル内の文字列を調査できないファイル（普通に開くことができないエクセルファイル）については、別シートに調査できなかったファイルとして一覧表示（ハイパーリンク付き）します。

フォルダ内の全エクセルファイルの文字列検索の動作原理

動作はfindメソッドで任意の文字列を検索し、該当した場合はファイル名を取得する。というものです。

任意のフォルダを選択する
任意の文字列（キーワード１）をinputボックスで入力する。
任意の文字列（キーワード２）をinputボックスで入力する。
指定した任意のフォルダを走査し、再帰モジュールにより一番深い位置にあるサブフォルダまで行く。
上記サブフォルダ内のエクセルファイルを一つ一つ開き、キーワード１をfindにより検索する。
キーワード１が該当した（含まれている）ファイルについて、キーワード２でfind検索する。
キーワード２に該当した（含まれている）ファイル名やファイルパス等を取得し、マクロを実行しているワークシート１（Thisworkibook.worksheets(1)）に表示させる。
５～７を繰り返し、そのフォルダ内のエクセルファイルの調査（open）が終わったら、一つ上のファイルに移行し、５～７を繰り返す。
パスワードロックされているエクセルファイルについては、ファイル名およびファイルパスをワークシート２（Thisworkibook.worksheets(2)）に表示させる。

サンプルコード

Dim inp_moji As String
Dim inp_moji_2 As String
Dim write_cell_count As Long
Dim error_write_cell As Long

Sub 文字検索マクロver3()

    Dim objFSO As filesystemobject
    Dim strDir As String
    Dim i As Long
    Dim dig As FileDialog
    Dim before_moji_1 As String
    Dim before_moji_2 As String
    Dim rslt As VbMsgBoxResult
    
    Worksheets(1).Activate
    
    rslt = MsgBox("開始前に現在開いているエクセルファイルを閉じてください。" & vbCrLf & vbCrLf & "検索を開始しますか？", _
                    Buttons:=vbYesNo + vbExclamation)
                    
    If Not rslt = vbYes Then
        Exit Sub
    End If
    
    before_moji_1 = Cells(2, 1) '前回の文字を表示するために記憶する
    before_moji_2 = Cells(3, 1) '前回の文字を表示するために記憶する
    
    ThisWorkbook.Worksheets(1).UsedRange.Clear
    ThisWorkbook.Worksheets(2).UsedRange.Clear

    Cells(1, 1) = "検索文字"  '前回の文字を表示する
    Cells(2, 1) = before_moji_1 '前回の文字を表示する
    Cells(3, 1) = before_moji_2 '前回の文字を表示する
    
    ThisWorkbook.Worksheets(2).Cells(1, 1) = "調査できなかったファイル"
    ThisWorkbook.Worksheets(2).Cells(3, 1) = "ファイル名"
    

    write_cell_count = 5
    error_write_cell = 4
    
    
    'フォルダ選択
    
    Set dig = Application.FileDialog(msoFileDialogFolderPicker)
    If dig.Show = False Then
        Exit Sub
    End If
    
    strDir = dig.SelectedItems(1)
    
    'インスタンス生成
    Set objFSO = New filesystemobject
    
    'フォルダの存在確認
    If Not objFSO.folderexists(strDir) Then
        MsgBox ("指定のフォルダは存在しません。")
        Exit Sub
    End If
    
    'キーワード１の取得
    inp_moji = GetMoji()
    
    If inp_moji = "" Then    'キーワード１をキャンセルしたら処理を終了する
        Exit Sub
    End If
    
    Cells(1, 1) = "検索文字"
    Cells(2, 1) = "キーワード１　：　" & inp_moji
    
    'キーワード２の取得
    inp_moji_2 = GetMoji_2()
    Cells(3, 1) = "キーワード２　：　" & inp_moji_2
    
    rslt = MsgBox("選択フォルダ　：　" & strDir & vbCrLf & vbCrLf & _
                    "キーワード１　：　" & inp_moji & vbCrLf & vbCrLf & _
                    "キーワード２　：　" & inp_moji_2 & vbCrLf & vbCrLf & _
                    "検索を開始しますか？", _
                    Buttons:=vbYesNo + vbExclamation)
                    
    If Not rslt = vbYes Then
        Exit Sub
    End If
    
    Application.Wait Now() + TimeValue("00:00:01")
        
    Cells(5, 1) = "ファイル名"
    Cells(5, 2) = "シート名"
    'Cells(5, 3) = "セル番号"
    Cells(5, 3) = "最初に検索ヒットした内容"
    Cells(5, 4) = "最終更新日"
    
   
    
    Application.ScreenUpdating = False
    
    i = 6 '開始位置
    
    '再帰モジュールのコール
    Call GetDirFiles(objFSO.GetFolder(strDir), i)
    
    'オブジェクトの解放
    Set objFSO = Nothing
    
     If Cells(6, 1) = "" Then
        Cells(6, 1) = "　該当ファイルはありません"
        If Worksheets(2).Cells(4, 1) <> "" Then
            Cells(7, 1) = "　※　調査できなかったファイルあり"
        End If
    End If
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
         
    Columns("A").AutoFit
    Columns("B").AutoFit
    Columns("C").AutoFit
    Columns("D").AutoFit
    Worksheets(2).Columns("A").AutoFit
    Worksheets(2).Columns("B").AutoFit
    
End Sub


Sub GetDirFiles(ByVal objFolder As folder, ByRef i As Long)

    Dim objFolderSub As folder
    Dim objfile As File
    
    'サブフォルダの取得
    For Each objFolderSub In objFolder.subfolders
        i = i + 1
        Call GetDirFiles(objFolderSub, i)
    Next
    
    'ファイルの取得
    For Each objfile In objFolder.Files
        i = i + 1
        Call Opfile(objfile)  'ファイルオープンのプロシージャを呼び出し
    Next
    
    'オブジェクトの解放
    Set objFolderSub = Nothing
    Set objfile = Nothing
    
End Sub


Function GetMoji() As String
    
    'キーワード１入力
    GetMoji = InputBox(prompt:="キーワード１　を入力してください", _
                    Title:="検索文字入力")
End Function

Function GetMoji_2() As String
    
    'キーワード２入力
    GetMoji_2 = InputBox(prompt:="キーワード２　を入力してください", _
                    Title:="検索文字入力")
End Function


Sub Opfile(ByVal wb As Variant)
    
    '文字検索
    Dim kensaku_moji_r As Range
    Dim find_cell As Range
    Dim find_cell_2 As Range
    Dim next_find_cell As Range
    Dim n As Long
    Dim m As Long
    Dim wb_book As Workbook
    Dim hyplink As Hyperlink
    
    If wb.Name Like "*.xls*" Then
        Application.EnableEvents = False  'マクロ自動実行停止
        Application.DisplayAlerts = False  '破損ファイルのメッセージ停止
        
        On Error Resume Next
        
        Set wb_book = Workbooks.Open(FileName:=wb, _
                                corruptload:=xlRepairFile, _
                                UpdateLinks:=0, _
                                Password:="")   '破損ファイルを修復して開く、リンクを更新しない、パスワードは文字入力していない
        Select Case Err.Number
        Case 1004
            ThisWorkbook.Worksheets(2).Cells(error_write_cell, 1) = wb.Name
            Set hyplinks = ThisWorkbook.Worksheets(2).Hyperlinks.Add( _
                            anchor:=ThisWorkbook.Worksheets(2).Cells(error_write_cell, 1), _
                            Address:=wb.Path, _
                            TextToDisplay:=wb.Name)
            error_write_cell = error_write_cell + 1
            Exit Sub
        End Select
        
        Application.EnableEvents = True
        
        For m = 1 To Worksheets.Count
            Set find_cell = wb_book.Worksheets(m).UsedRange.Find( _
                            what:=inp_moji, _
                            MatchCase:=False, _
                            matchbyte:=False, _
                            lookat:=xlPart)
            If Not (find_cell Is Nothing) Then
                For n = 1 To Worksheets.Count
                    Set find_cell_2 = wb_book.Worksheets(n).UsedRange.Find( _
                                what:=inp_moji_2, _
                                MatchCase:=False, _
                                matchbyte:=False, _
                                lookat:=xlPart)
                    If Not (find_cell_2 Is Nothing) Then
                        write_cell_count = write_cell_count + 1
                        With ThisWorkbook.Worksheets(1)
                        .Cells(write_cell_count, 2) = wb_book.Worksheets(m).Name
                        .Cells(write_cell_count, 3) = find_cell.Address
                        .Cells(write_cell_count, 4) = find_cell
                        .Cells(write_cell_count, 5) = wb.datelastmodified
                        Set hyplinks = .Hyperlinks.Add(anchor:=.Cells(write_cell_count, 1), _
                            Address:=wb_book.FullName, _
                            SubAddress:=Worksheets(m).Name & "!" & find_cell.Address, _
                            TextToDisplay:=wb_book.Name)    'texttodisplay と、アンカーのセル番号を変えている
                        End With
                        
                        Exit For 'n のfor文
                    End If
                Next n
                Exit For 'm のfor文
            End If
        Next m
        
        Application.DisplayAlerts = False
        Call wb_book.Close(savechanges:=False)
        Application.DisplayAlerts = True
        
    End If
End Sub

VBA｜フォルダ内の全エクセルファイルの文字列検索マクロ

フォルダ内の全エクセルファイルの文字列検索マクロの仕様

フォルダ内の全エクセルファイルの文字列検索の動作原理

サンプルコード

コメント