概要
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 | セル内容 |
【参考】自由にインストールが可能な場合に使いたいツール
TresGrep
- http://hp.vector.co.jp/authors/VA055804/TresGrep/
- 普段使用しているソフト。
検索が高速なことはもちろん、多様なファイル形式に対応していることから探し漏れが生じづらく信頼性が高い。
また、ソフト自体の起動終了が早いため、ちょっとした時にも使いやすい。
RelaxTools Addin
- http://software.opensquare.net/relaxtools/
- Excel用アドオン。Grep以外にも何かの時に使いそうなマクロが大量に含まれている。
以上