Excelファイルを一括検索するVBAマクロ

概要

Excel-VBAを使って、Excelファイルを一括検索するソフトを作成しました。

本当はもっとちゃんとしたツールが沢山存在しており、 そちらを利用した方が速度的にも精度的にも有利です。
しかし、会社のルールでソフトが自由にインストールできないなどの理由から、 そういったツールの使えない環境でも似たような検索ができるように作成しました。

  • コピーで作成しやすいよう、1シート&1モジュールで完結させています
  • 検索キーワードは部分一致、かつワイルドカードVBA Like形式)に対応しています
  • 余計なファイルは検索から除外することで高速に処理できるよう、 「ファイル名フィルタ」および「除外フォルダ名」を搭載しています
  • 図形に含まれたテキストも検索対象とします。
    その時、図形の左上端がセル位置として表示されます。
  • パスワードがかかっている等の理由で開けないファイルがあった場合、
    検索結果の代わりにエラーメッセージが出力されます。

なお、勘のいい方ならお気付きでしょうが基本的に自分用です。
二次利用は自由ですが自己責任でお願い致します。


Step1. スクリプト

VBAエディタで「標準スクリプト」を追加して、 以下の内容を貼り付け。

'================================
' Excel-Grep検索
'================================

Const SHEET_OUTPUT = "search"
Const CELL_PRINT_COL = 1
Const CELL_PRINT_ROW = 9
Const CELL_ROOT_DIR = "B3"
Const CELL_SEARCH_WORD = "B4"
Const CELL_FILE_FILTER = "B5"
Const CELL_EXCLUDE_DIR = "B6"

' 現在の出力行
Dim nowRow As Long
' 最初の検索フォルダ
Dim rootDir As String
' 検索用Excel
Dim xlApp As Excel.Application

' メイン処理
Sub searchMacro()
    Dim outputSht As Worksheet
    Dim excludeDir As Dictionary
    Dim rootDir As String
    Dim searchWord As String
    Dim fileFilter As String
    Dim s As String

    Set outputSht = ThisWorkbook.Sheets(SHEET_OUTPUT)
    Set excludeDir = New Dictionary
    nowRow = CELL_PRINT_ROW

    ' 入力取得
    With ouputSht
        rootDir = .Range(CELL_ROOT_DIR)
        searchWord = .Range(CELL_SEARCH_WORD)
        fileFilter = .Range(CELL_FILE_FILTER)
        For Each s In Split(.Range(CELL_EXCLUDE_DIR), ";")
            excludeDir.Add s, Empty
        Next
    End With

    ' 入力チェック
    If "" Like searchWord Then
        MsgBox "検索ワードを入力してください"
        Exit Sub
    End If

    ' 結果シート初期化
    With outputSht
        .Cells(CELL_PRINT_ROW, CELL_PRINT_COL).Select
        .Range(.Cells(CELL_PRINT_ROW, CELL_PRINT_COL), .Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
        .Range("C:C,F:F").NumberFormatLocal = "@"
    End With

    ' 検索用Excel起動
    Set xlApp = New Excel.Application
    On Error Goto GrepErr

    ' フォルダ内を検索
    Call searchDir(rootDir, searchWord, fileFilter, excludeDir)

    ' 検索用Excel終了
    xlApp.Quit
    Set xlApp = Nothing
    On Error Goto 0

    If 0 < nowRow - CELL_PRINT_ROW Then
        MsgBox "検索結果:キーワード「" & searchWord & "」に、" & Format(nowRow - CELL_PRINT_ROW, "#,##0") & "件の一致がありました。"
    Else
        MsgBox "検索結果:キーワード「" & searchWord & "」への一致はありませんでした。"
    End If
    Application.StatusBar = ""
    Exit Sub

GrepErr:
    Application.StatusBar = ""
    xlApp.Quit
    Set xlApp = Nothing
    MsgBox "<エラー発生>" & vbCrLf & _
        "Number=" & Err.Number & vbCrLf & _
        "Source=" & Err.Source & vbCrLf & _
        "Description=" & Err.Description
End Sub

' フォルダ内検索
Sub searchDir(ByVal searchPath As String, ByVal searchWord As String, ByVal fileFilter As String, ByVal excludeDir As Dictionary)
    Dim curDir As Folder, subDir As Folder, f As File

    Application.StatusBar = "検索中フォルダ:" & searchPath
    DoEvents

    ' フォルダを開く
    With New FileSystemObject
        Set curDir = .GetFolder(searchPath)
    End With

    '------ ファイルを検索 ------
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For Each f In curDir.Files
        If f.Name Like fileFilter Then
            Call grepExcel(searchPath, f.Name, searchWord)
        End If
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    '------ サブフォルダを検索 ------
    For Each subDir In curDir.SubFolders
        If Not excludeDir.Exists(subDir.Name) Then
            Call searchDir(subDir.Path, searchWord, fileFilter, excludeDir)
        End If
    Next
End Sub

' Excelファイル内を検索
Sub grepExcel(ByVal searchPath As String, ByVal searchFile As String, ByVal searchWord As String)
    Dim wb As Workbook
    Dim sht As Worksheet

    ' ファイルを開く
    On Error Resume Next
    Set wb = xlApp.Workbooks.Open(Filename:=searchPath & "\" & searchFile, UpdateLinks:=0, ReadOnly:=True, _
            IgnoreReadOnlyRecommended:=True, Password:="")
    If Err.Number <> 0 Then
        Call writeSheet(searchPath, searchFile, "-", "-", "ERROR: 開けないファイル")
        Exit Sub
    End If
    On Error Goto 0

    ' 各シートを検索
    For Each sht In wb.Worksheets
        Dim aryWhole As Variant
        Dim crow As Long, ccol As Long, ctext As String
        Dim shp As Shape

        '------ セル検索 ------
        With sht
            aryWhole = .Range("A1", .Cells.SpecialCells(xlCellTypeLastCell))
            If vbArray < VarType(aryWhole) Then
                For crow = LBound(aryWhole) To UBound(aryWhole)
                    For ccol = LBound(aryWhole, 2) To UBound(aryWhole, 2)
                        ctext = aryWhole(crow, ccol)
                        If ctext Like "*" & searchWord & "*" Then
                            ' 見つかった内容を書き込み
                            Call writeSheet(searchPath, searchFile, sht.Name, .Cells(crow, ccol).Address(False, False), ctext)
                        End If
                    Next
                Next
            End If
        End With

        '------ 図形検索 ------
        For Each shp In sht.Shapes
            With shp
                ' 図形内テキストを検索 (テキストのない図形は無視)
                ctext = ""
                On Error Resume Next
                ctext = .TextFrame.Characters.Text
                On Error Goto 0

                If ctext Like "*" & searchWord & "*" Then
                    ' 見つかった内容を書き込み
                    Call writeSheet(searchPath, searchFile, sht.Name, .TopLeftCell.Address(False, False) & " *", ctext)
                End If
            End With
        Next
    Next

    ' ファイルを閉じる
    wb.Close saveChanges:=False
End Sub

' 検索結果を書き込む
Sub writeSheet(ByVal searchPath As String, ByVal searchFile As String, ByVal resultSheet As String, ByVal resultAddr As String, ByVal resultText As String)
    ThisWorkbook.Sheets(SHEET_OUTPUT).Cells(nowRow, CELL_PRINT_COL).Resize(, 6) = Array( _
          Replace(searchPath, rootDir, "") _
        , searchFile _
        , resultSheet _
        , resultAddr _
        , Replace("=HYPERLINK(""["" & $B$3 & $A# & ""\"" & $B# & ""]"" & $C# & ""!"" & $D#, ""LINK"")", "#", nowRow) _
        , resultText _
    )
    nowRow = nowRow + 1
End Sub

Step2. 操作シート

ファイル内に「search」シートを作成して、以下のテーブルをA1セルへ貼り付ける。
その後、フォーム部品からボタンを配置、スクリプトの「searchMacro()」を割り当てる。

Excel-Grep検索
検索フォルダ
検索ワード(部分一致、ワイルドカード可)
ファイルフィルタ(ワイルドカード可)
除外フォルダ(";"区切り、完全一致)
フォルダ名ファイル名シート名セル番号LINKセル内容

【参考】自由にインストールが可能な場合に使いたいツール

  1. TresGrep

    • http://hp.vector.co.jp/authors/VA055804/TresGrep/
    • 普段使用しているソフト。
      検索が高速なことはもちろん、多様なファイル形式に対応していることから探し漏れが生じづらく信頼性が高い。
      また、ソフト自体の起動終了が早いため、ちょっとした時にも使いやすい。
  2. RelaxTools Addin

以上