Option Explicit
Private Const CONFIG_COL As Long = 2 ' 設定列
Private Const CONFIG_START_ROW As Long = 2 ' 設定開始行
Private Const DATA_START_ROW As Long = 12 ' 出力開始行
' ####################################################
' 描画制限プロパティ
' ####################################################
Property Let Focus(ByVal Flag As Boolean)
With Application
.EnableEvents = Not Flag
.ScreenUpdating = Not Flag
.Calculation = IIf(Flag, xlCalculationManual, xlCalculationAutomatic)
End With
End Property
' ====================================================
' GREP実行
' ====================================================
Public Sub GrepBooks()
Dim shtMain As Worksheet ' ワークシート
Dim strPath As String ' フォルダパス
Dim strPassword As String ' パスワード
Dim strSheetName As String ' 検索対象シート名
Dim strDsShtName As String ' 検索除外シート名
Dim strWords As String ' 検索文字列
Dim intExtCol As Integer ' 参考情報出力列
Dim fso As Object ' ファイルシステムオブジェクト
Dim fl As Variant ' ファイルオブジェクト
Dim intTargetCnt As Integer ' 対象ファイル数
Dim intProcCnt As Integer ' 処理件数
Dim lngIdx As Long
Dim colGrep As Collection ' GREP結果格納用コレクション
Dim dicGrep As Object ' GREP結果ディクショナリ
Dim varGrep As Variant ' コレクション取出し用オブジェクト（ディクショナリ）
Dim firstRow
Dim lastRow
Dim countIndex
Set shtMain = ActiveSheet
' フォルダ存在チェック
strPath = shtMain.Cells(CONFIG_START_ROW, CONFIG_COL).Text
If Dir(strPath, vbDirectory) = "" Then
MsgBox "指定のフォルダ「" & strPath & "」は存在しません。", vbExclamation
Exit Sub
End If
' 確認ダイアログ
If MsgBox("指定したフォルダ以下にあるxlsxファイルをGREPします。" & vbCrLf & "よろしいですか?", vbQuestion + vbYesNo) = vbNo Then
Exit Sub
End If
' 設定値取得
strPassword = shtMain.Cells(CONFIG_START_ROW + 1, CONFIG_COL).Text
strSheetName = shtMain.Cells(CONFIG_START_ROW + 2, CONFIG_COL).Text
strDsShtName = shtMain.Cells(CONFIG_START_ROW + 3, CONFIG_COL).Text
strWords = shtMain.Cells(CONFIG_START_ROW + 4, CONFIG_COL).Text
intExtCol = Val(shtMain.Cells(CONFIG_START_ROW + 5, CONFIG_COL).Text)
lngIdx = 0
intTargetCnt = 0
intProcCnt = 0
' 描画制限
Focus = True
firstRow = DATA_START_ROW
lastRow = shtMain.UsedRange.Rows.Count
For countIndex = lastRow To firstRow Step -1
Rows(countIndex).Delete
Next
'Set clearRng = shtMain.Range("A12:F" & (shtMain.UsedRange.Rows.Count - 12))
'For Each clearRow In clearRng.Rows
' clearRow.ClearContents
'Next clearRow
' 対象ファイル数取得
Set fso = CreateObject("Scripting.FileSystemObject")
For Each fl In fso.GetFolder(strPath).Files
If UCase(fso.GetExtensionName(fl.Path)) = "XLSX" Or UCase(fso.GetExtensionName(fl.Path)) = "XLS" Or UCase(fso.GetExtensionName(fl.Path)) = "XLSM" Then
intTargetCnt = intTargetCnt + 1
End If
Next
' ファイルごとに処理
For Each fl In fso.GetFolder(strPath).Files
If UCase(fso.GetExtensionName(fl.Path)) = "XLSX" Or UCase(fso.GetExtensionName(fl.Path)) = "XLS" Or UCase(fso.GetExtensionName(fl.Path)) = "XLSM" Then
' ステータスバー更新
Focus = False
intProcCnt = intProcCnt + 1
Application.StatusBar = "GREP処理中... (" & CStr(intProcCnt) & "/" & CStr(intTargetCnt) & " ファイル)"
Application.DisplayAlerts = True
Focus = True
' 各ブックを検索
Set colGrep = SearchBook(fl.Path, strPassword, strSheetName, strDsShtName, strWords, intExtCol)
' 結果出力
For Each varGrep In colGrep
shtMain.Cells(DATA_START_ROW + lngIdx, 1).Value = CStr(lngIdx + 1)
shtMain.Cells(DATA_START_ROW + lngIdx, 2).Value = fl.Name
shtMain.Cells(DATA_START_ROW + lngIdx, 3).Value = varGrep("Sheet")
shtMain.Cells(DATA_START_ROW + lngIdx, 4).Value = varGrep("Row")
shtMain.Cells(DATA_START_ROW + lngIdx, 5).Value = varGrep("Text")
ActiveSheet.Cells(DATA_START_ROW + lngIdx, 6).Value = varGrep("ExtText")
lngIdx = lngIdx + 1
Next
End If
Next
Focus = False
' ステータスバークリア
Application.StatusBar = False
MsgBox "GREP完了" & vbCrLf & CStr(intTargetCnt) & "ファイル中一致した箇所：" & CStr(lngIdx), vbInformation
End Sub
' -----------------------------------------------
' 個別ファイル検索
' -----------------------------------------------
Private Function SearchBook(pFilePath As String, pPassword As String, pSheet As String, pDsSht As String, pWords As String, pExtCol As Integer) As Collection
Dim wb As Workbook ' ワークブック
Dim ws As Variant ' ワークシート
Dim rng As Range ' 検索一致セル
Dim adr As String ' 最初に見つかったセルのAddress
Dim dicGrep As Object ' GREP結果ディクショナリ
Dim colGrep As New Collection ' GREP結果格納用コレクション
Dim strDsShts() As String ' 検索除外シート名をSplitした配列
Dim dicDsSht As Object
Dim strWords() As String ' 検索文字列をSplitした配列
Dim i As Integer
' ワークブックを開く
If pPassword <> "" Then
Set wb = Workbooks.Open(Filename:=pFilePath, Password:=pPassword, ReadOnly:=True, UpdateLinks:=0)
Else
Set wb = Workbooks.Open(Filename:=pFilePath, ReadOnly:=True, UpdateLinks:=0)
End If
ActiveWindow.Visible = False
' 検索除外シート名
strDsShts = Split(pDsSht, ",")
Set dicDsSht = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(strDsShts)
dicDsSht.Add strDsShts(i), 1
Next i
' 検索文字列Split
strWords = Split(pWords, ",")
' ワークシートでループ
For Each ws In wb.Worksheets
' シート名が一致する場合のみ
If InStr(ws.Name, pSheet) <> 0 And Not dicDsSht.Exists(ws.Name) And ws.Visible Then
' 検索文字列ごとにループ
For i = 0 To UBound(strWords)
' 検索（初回）
Set rng = ws.Cells.Find(strWords(i))
' 検索にヒットした場合のみ処理
If Not rng Is Nothing Then
' 最初に見つかったセルのAddfressを保持（終了判定用）
adr = rng.Address
' 表示行の場合のみ処理
If Not rng.EntireRow.Hidden Then
Set dicGrep = CreateObject("Scripting.Dictionary")
dicGrep.Add "Sheet", ws.Name
dicGrep.Add "Row", rng.Row
dicGrep.Add "Text", rng.Text
If pExtCol > 0 Then dicGrep.Add "ExtText", ws.Cells(rng.Row, pExtCol).Text
' コレクションに追加
colGrep.Add dicGrep
End If
' 検索（2件目以降）
Do
Set rng = ws.Cells.FindNext(After:=rng)
If rng Is Nothing Then Exit Do
If rng.Address = adr Then Exit Do
' 表示行の場合のみ処理
If Not rng.EntireRow.Hidden Then
Set dicGrep = CreateObject("Scripting.Dictionary")
dicGrep.Add "Sheet", ws.Name
dicGrep.Add "Row", rng.Row
dicGrep.Add "Text", rng.Text
If pExtCol > 0 Then dicGrep.Add "ExtText", ws.Cells(rng.Row, pExtCol).Text
' コレクションに追加
colGrep.Add dicGrep
End If
Loop
End If
Dim shp As Shape
For Each shp In ws.Shapes
Dim strText As String
Dim rowLIndex, colLIndex, rowRIndex, colRIndex
Dim pos As Integer
On Error Resume Next
strText = shp.TextFrame.Characters.Text
pos = InStr(strText, strWords(i))
If strText <> "" And pos > 0 Then
Set dicGrep = CreateObject("Scripting.Dictionary")
dicGrep.Add "Sheet", ws.Name
dicGrep.Add "Row", shp.TopLeftCell.Row
dicGrep.Add "Text", strText
rowLIndex = shp.TopLeftCell.Row
colLIndex = shp.TopLeftCell.Column
rowRIndex = shp.BottomRightCell.Row
colRIndex = shp.BottomRightCell.Column
dicGrep.Add "ExtText", "図形位置：[" & rowLIndex & "行:" & colLIndex & "列]、[" & rowRIndex & "行:" & colRIndex & "列]"
' コレクションに追加
colGrep.Add dicGrep
End If
Next shp
Next i
End If
Next
' ワークブッククローズ
wb.Close SaveChanges:=False
Set SearchBook = colGrep
End Function
网友评论