概要
Excel-VBAを使って、Excelファイルを一括検索するソフトを作成しました。
本当はもっとちゃんとしたツールが沢山存在しており、
そちらを利用した方が速度的にも精度的にも有利です。
しかし、会社のルールでソフトが自由にインストールできないなどの理由から、
そういったツールの使えない環境でも似たような検索ができるように作成しました。
- コピーで作成しやすいよう、1シート＆1モジュールで完結させています
- 検索キーワードは部分一致、かつワイルドカード（VBA Like形式）に対応しています
- 余計なファイルは検索から除外することで高速に処理できるよう、
「ファイル名フィルタ」および「除外フォルダ名」を搭載しています
- 図形に含まれたテキストも検索対象とします。
その時、図形の左上端がセル位置として表示されます。
- パスワードがかかっている等の理由で開けないファイルがあった場合、
検索結果の代わりにエラーメッセージが出力されます。
なお、勘のいい方ならお気付きでしょうが基本的に自分用です。
二次利用は自由ですが自己責任でお願い致します。
VBAエディタで「標準スクリプト」を追加して、
以下の内容を貼り付け。
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
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
Set xlApp = New Excel.Application
On Error Goto GrepErr
Call searchDir(rootDir, searchWord, fileFilter, excludeDir)
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
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()」を割り当てる。
【参考】自由にインストールが可能な場合に使いたいツール
TresGrep
RelaxTools Addin
以上
