(cache) 【Excel VBA】複数の単語をGrepする(1)

【Excel VBA】複数の単語をGrepする(1)

こんにちは、みすくです。

指定したディレクトリ配下を、複数の単語でいっきにGrepするツール作りました。
結構適当に作っちゃったので、解説をしつつメンテナンスしていきます。
追記：大幅にメンテしました。
でもVBAにあまり慣れていないのと、ちょっと面倒になって雑なところがあります。

取りあえず、できあがったものと、コードを公開します。
解説は徐々にやっていきます。

ちなみに、Excelはマイクロソフトさんの製品だけありまして、
Windows（OS）に対して強力な言語です。
つまり、わたしがあなたのマシンを壊そうと思ったら、
このファイルに仕込めるから、無防備にダウンロードすんなよってことです。
ま、わたしは他人に嫌われると文字通り痛い目に会うと思っていますし、
まあ便利みすくちゃん素敵とかモテたいだけなんで、
公開している通りのコードが入ってます。

ダウンロードはこちら

Option Explicit

'対象ディレクトリ
Public topDir As String
'出力シート名
Public outputSheetName As String
'名前の定義
Public name As String
'名前を定義する列
Public nameCols As String

Option Explicit

'対象ディレクトリ

Public topDir As String

'出力シート名

Public outputSheetName As String

'名前の定義

Public name As String

'名前を定義する列

Public nameCols As String

Option Explicit

'設定ワークシートオブジェクト
Public oConfSh As Worksheet
'出力シートテンプレート
Public oTmpSh As Worksheet
'出力シート
Public oOutSh As Worksheet
'検索文字列
Dim searchList() As String
'検索文字列ソース
Dim srcSearchList() As String
'検索対象ファイル（拡張子）
Dim extentionList() As String
'英大文字・小文字を区別する
Public isIgnoreCase As Boolean
'単語単位で検索する
Public isBreak As Integer
'正規表現
Public isRegEx As Integer
'結果のハイライト
Public isHylight As Integer

Public Function setExtentionList(ByRef target() As String)
    extentionList = target
End Function

Public Function setSearchList(ByRef target() As String)
    searchList = target
End Function

Public Function getSearchList()
    getSearchList = searchList
End Function

Public Function setSrcSearchList(ByRef target() As String)
    srcSearchList = target
End Function

Public Function getSrcSearchList()
    getSrcSearchList = srcSearchList
End Function

Public Function termClassSearchOptionInfo()
    Set oConfSh = Nothing
    Set oTmpSh = Nothing
    Set oOutSh = Nothing
    Erase searchList
    Erase extentionList
End Function

'--------------------------------------------------------------------------------
' 関 数 名：拡張子確認
' 処理概要：対象の拡張子であるか確認する
' 引  　数：ByVal sExtention As String 拡張子
' 返 却 値：True 該当
'           False 該当しない
'--------------------------------------------------------------------------------
Public Function isTargetExtention(ByVal sExtention As String)
    Dim res As Variant
    'ワイルドカードの場合True
    res = Filter(extentionList, "*", True, vbTextCompare)
    If sExtention <> "" And UBound(res) <> -1 Then
        isTargetExtention = True
        Exit Function
    End If
    '拡張子がマッチした場合True
    res = Filter(extentionList, sExtention, True, vbTextCompare)
    If UBound(res) <> -1 Then
        isTargetExtention = True
        Exit Function
    End If
    isTargetExtention = False
End Function

Option Explicit

'設定ワークシートオブジェクト

Public oConfSh As Worksheet

'出力シートテンプレート

Public oTmpSh As Worksheet

'出力シート

Public oOutSh As Worksheet

'検索文字列

Dim searchList() As String

'検索文字列ソース

Dim srcSearchList() As String

'検索対象ファイル（拡張子）

Dim extentionList() As String

'英大文字・小文字を区別する

Public isIgnoreCase As Boolean

'単語単位で検索する

Public isBreak As Integer

'正規表現

Public isRegEx As Integer

'結果のハイライト

Public isHylight As Integer

Public Function setExtentionList(ByRef target() As String)

extentionList = target

End Function

Public Function setSearchList(ByRef target() As String)

searchList = target

End Function

Public Function getSearchList()

getSearchList = searchList

End Function

Public Function setSrcSearchList(ByRef target() As String)

srcSearchList = target

End Function

Public Function getSrcSearchList()

getSrcSearchList = srcSearchList

End Function

Public Function termClassSearchOptionInfo()

Set oConfSh = Nothing

Set oTmpSh = Nothing

Set oOutSh = Nothing

Erase searchList

Erase extentionList

End Function

'--------------------------------------------------------------------------------

' 関数名：拡張子確認

' 処理概要：対象の拡張子であるか確認する

' 引　数：ByVal sExtention As String 拡張子

' 返却値：True 該当

' False 該当しない

'--------------------------------------------------------------------------------

Public Function isTargetExtention(ByVal sExtention As String)

Dim res As Variant

'ワイルドカードの場合True

res = Filter(extentionList, "*", True, vbTextCompare)

If sExtention <> "" And UBound(res) <> -1 Then

isTargetExtention = True

Exit Function

End If

'拡張子がマッチした場合True

res = Filter(extentionList, sExtention, True, vbTextCompare)

If UBound(res) <> -1 Then

isTargetExtention = True

Exit Function

End If

isTargetExtention = False

End Function

Option Explicit

'--------------------------------------------------------------------------------
' 関 数 名：初期処理
' 処理概要：初期設定を行う
' 引  　数：なし
' 返 却 値：なし
'--------------------------------------------------------------------------------
Function init()
    'カーソル変更
    Application.Cursor = xlWait
    'ステータスバー
    Application.StatusBar = "処理中......"
    '描画抑止
    Application.ScreenUpdating = False
    '自動計算抑止
    Application.Calculation = xlCalculationManual
End Function

'--------------------------------------------------------------------------------
' 関 数 名：終期処理
' 処理概要：後始末を行う
' 引  　数：なし
' 返 却 値：なし
'--------------------------------------------------------------------------------
Function term()
    '自動計算抑止解除
    Application.Calculation = xlCalculationAutomatic
    '描画抑止解除
    Application.ScreenUpdating = True
    'カーソル変更
    Application.Cursor = xlDefault
    'ステータスバー
    Application.StatusBar = False
End Function

'--------------------------------------------------------------------------------
' 関 数 名：ハイパーリンク挿入
' 処理概要：ハイパーリンクを設定する
' 引  　数：なし
' 返 却 値：なし
'--------------------------------------------------------------------------------
Public Function addHyperLink(ByRef oConfSh As Worksheet)
    Dim startRow As Long '検索先頭行
    Dim endRow As Long '検索末尾行
    Dim col As Long '検索列
    Dim idx As Long
    
    startRow = oConfSh.Range(startOutAdd).Row
    col = oConfSh.Range(startOutAdd).Column
    endRow = oConfSh.Cells(Rows.Count, "G").End(xlUp).Row
    
    With oConfSh.Hyperlinks
        For idx = startRow To endRow
            .Add Anchor:=oConfSh.Cells(idx, "G"), Address:=""
        Next idx
    End With
    With oConfSh.Range(oConfSh.Cells(startRow, "G"), oConfSh.Cells(endRow, "G"))
            .Font.name = "Meiryo UI"
            .Font.Size = 10
    End With
End Function

Option Explicit

'--------------------------------------------------------------------------------

' 関数名：初期処理

' 処理概要：初期設定を行う

' 引　数：なし

' 返却値：なし

'--------------------------------------------------------------------------------

Function init()

'カーソル変更

Application.Cursor = xlWait

'ステータスバー

Application.StatusBar = "処理中......"

'描画抑止

Application.ScreenUpdating = False

'自動計算抑止

Application.Calculation = xlCalculationManual

End Function

'--------------------------------------------------------------------------------

' 関数名：終期処理

' 処理概要：後始末を行う

' 引　数：なし

' 返却値：なし

'--------------------------------------------------------------------------------

Function term()

'自動計算抑止解除

Application.Calculation = xlCalculationAutomatic

'描画抑止解除

Application.ScreenUpdating = True

'カーソル変更

Application.Cursor = xlDefault

'ステータスバー

Application.StatusBar = False

End Function

'--------------------------------------------------------------------------------

' 関数名：ハイパーリンク挿入

' 処理概要：ハイパーリンクを設定する

' 引　数：なし

' 返却値：なし

'--------------------------------------------------------------------------------

Public Function addHyperLink(ByRef oConfSh As Worksheet)

Dim startRow As Long '検索先頭行

Dim endRow As Long '検索末尾行

Dim col As Long '検索列

Dim idx As Long

startRow = oConfSh.Range(startOutAdd).Row

col = oConfSh.Range(startOutAdd).Column

endRow = oConfSh.Cells(Rows.Count, "G").End(xlUp).Row

With oConfSh.Hyperlinks

For idx = startRow To endRow

.Add Anchor:=oConfSh.Cells(idx, "G"), Address:=""

Next idx

End With

With oConfSh.Range(oConfSh.Cells(startRow, "G"), oConfSh.Cells(endRow, "G"))

.Font.name = "Meiryo UI"

.Font.Size = 10

End With

End Function

Option Explicit

'★★★★検索文字列リストの先頭アドレス
Const searchListAdd As String = "B10"
'★★★★対象拡張子先頭アドレス
Const extentionListAdd As String = "D10"
'★★★★対象ディレクトリ先頭アドレス
Const dirPathAdd As String = "G10"
'★★★★出力先先頭アドレス
Const startOutAdd As String = "A6"

'--------------------------------------------------------------------------------
' 関 数 名：まとめてGrep
' 処理概要：対象ディレクトリ配下にあるファイルから、検索対象文字列リストの文字列を検索する。
' 引  　数：なし
' 返 却 値：なし
'--------------------------------------------------------------------------------
Public Sub ListGrep()
    Dim searchOption As ClassSearchOptionInfo    '検索オプション情報
    Dim clsDirInfo() As ClassDirInfo '検索対象情報
    Dim iDir As Long '検索ディレクトリ情報カウンタ
    Dim nowResRow As Long   '結果出力行の先頭行
    
    Debug.Print Timer
    '初期処理
    Call init
    
    '画面入力値取得
    Set searchOption = getSearchOption()
    '検索ディレクトリ情報取得
    clsDirInfo = getTargetInfo(searchOption.oConfSh)
    
    For iDir = 0 To UBound(clsDirInfo)
        '出力シートを作成
        searchOption.oTmpSh.Copy After:=ThisWorkbook.Worksheets(Worksheets.Count)
        Set searchOption.oOutSh = ThisWorkbook.Worksheets(Worksheets.Count)
        
        '出力シート名前変更
        If clsDirInfo(iDir).outputSheetName <> "" Then
            searchOption.oOutSh.name = clsDirInfo(iDir).outputSheetName
        End If
        '名前の定義
        If clsDirInfo(iDir).name <> "" And clsDirInfo(iDir).nameCols <> "" Then
            searchOption.oOutSh.Range(clsDirInfo(iDir).nameCols).name = clsDirInfo(iDir).name
        End If
        '出力位置
        nowResRow = searchOption.oOutSh.Range(startOutAdd).Row
        'Grep実行
        Call doListGrep(clsDirInfo(iDir).topDir, searchOption, nowResRow)
    Next
    
    '終期処理
    Call term
    Call searchOption.termClassSearchOptionInfo
    Debug.Print Timer
    MsgBox "(っ´ω`ｃ)おしまい"
End Sub

'--------------------------------------------------------------------------------
' 関 数 名：リストGrep処理
' 処理概要：各ディレクトリ配下のファイルごとにGrepを行う。
' 引  　数：ByVal sTopPath As String
'               ByVal searchOption As ClassSearchOptionInfo
'               ByRef nowResRow As Long
' 返 却 値：なし
'--------------------------------------------------------------------------------
Function doListGrep(ByVal sTopPath As String, ByVal searchOption As ClassSearchOptionInfo, ByRef nowResRow As Long) As String()
    'ファイルシステムオブジェクト
    Dim oFSO As New FileSystemObject
    '先頭ディレクトリオブジェクト
    Dim topDir As Folder
    'ディレクトリオブジェクト
    Dim dir As Folder
    'ファイルオブジェクト
    Dim ofile As File

    '先頭ディレクトリオブジェクト取得
    Set topDir = oFSO.GetFolder(sTopPath)

    'ディレクトリ配下のディレクトリパス名を取得する
    For Each dir In topDir.SubFolders
        If dir.Attributes <> Alias Then
            Call doListGrep(dir.Path, searchOption, nowResRow)
        End If
    Next

    'ディレクトリ直下のファイル名を取得する
    For Each ofile In oFSO.GetFolder(sTopPath).Files
        '対象拡張子に該当するか確認する
        If searchOption.isTargetExtention(oFSO.GetExtensionName(ofile.name)) Then
            '文字列検索処理
            Call searchFromFile(ofile, searchOption, nowResRow)
            '該当した場合は次のファイルを検査
            Exit For
        End If
    Next
End Function

'--------------------------------------------------------------------------------
' 関 数 名：ファイルからの指定文字列検索
' 処理概要：ファイルを1行ずつ読み込み、リストの文字列があるか検索する
' 引  　数：ByVal ofile As File
'               ByVal searchOption As ClassSearchOptionInfo
'               ByRef nowResRow As Long
' 返 却 値：なし
'--------------------------------------------------------------------------------
Function searchFromFile(ByVal ofile As File, ByVal searchOption As ClassSearchOptionInfo, ByRef nowResRow As Long)
    Dim oFSO As New FileSystemObject    'ファイルシステムオブジェクト
    Dim oStream As TextStream           'ストリーム
    Dim buf, work As String             '読み込み領域
    Dim regEx As New regExp             '正規表現オブジェクト
    Dim regMc As MatchCollection        'Match Collection
    Dim iMc As Integer                          'マッチング箇所カウンタ
    Dim regMatch As Match                   '正規表現matcher
    Dim idx As Long                             '検索文字リストカウンタ
    Dim result(8, 0) As String  'ヒットした情報の格納領域
    Dim searchList() As String  '検索文字列
    Dim srcSeachList() As String '検索文字列ソース
    
    '検索範囲 = 文字列全体を検索
    regEx.Global = True
    '英大文字・小文字の区別
    regEx.IgnoreCase = searchOption.isIgnoreCase
    
    searchList = searchOption.getSearchList
    srcSeachList = searchOption.getSrcSearchList
    
    Set oStream = oFSO.OpenTextFile(ofile.Path, ForReading, False)
    Do While oStream.AtEndOfStream <> True
        '1行読み込み
        buf = oStream.ReadLine
        'トリムして空行、コメント行（「/*」、「//」、「#」)の場合はスキップ
        work = Replace(buf, vbTab, "")
        work = Trim(work)
        If work = "" Or Left(work, 2) = "/*" Or Left(work, 2) = "//" _
            Or Left(work, 1) = "#" Then
            GoTo Continue
        End If
        '検索文字リストとの比較
        For idx = 0 To UBound(searchList)
            regEx.Pattern = searchList(idx)
            Set regMc = regEx.Execute(buf)
            'ヒットした場合
            If regMc.Count > 0 Then
                result(0, 0) = "=N(INDIRECT(""R[-1]C"",FALSE))+1" 'No
                result(1, 0) = ofile.Path 'パス
                result(2, 0) = ofile.name 'ファイル名
                result(3, 0) = oFSO.GetExtensionName(ofile.name) '拡張子
                result(4, 0) = FileDateTime(ofile.Path) 'タイムスタンプ
                result(5, 0) = FileLen(ofile.Path)  'サイズ
                result(6, 0) = oStream.Line '行
                result(7, 0) = srcSeachList(idx)   '検索文字
                result(8, 0) = buf  '検索結果
                
                searchOption.oOutSh.Range(searchOption.oOutSh.Cells(nowResRow, 1), searchOption.oOutSh.Cells(nowResRow, 9)).Value = _
                    WorksheetFunction.Transpose(result)
                If searchOption.isHylight = xlOn Then
                    For iMc = 0 To regMc.Count - 1
                        Set regMatch = regMc.item(iMc)
                        With searchOption.oOutSh.Cells(nowResRow, "I").Characters(Start:=regMatch.FirstIndex + 1, Length:=regMatch.Length).Font
                            '★★★★色を赤にする
                            .Color = RGB(255, 0, 0)
                        End With
                    Next iMc
                End If
                nowResRow = nowResRow + 1
            End If
        Next idx
Continue:
    Loop
    oStream.Close
    Set oFSO = Nothing
End Function

'--------------------------------------------------------------------------------
' 関 数 名：検索文字列リスト取得
' 処理概要：検索文字列を取得する
' 引  　数：なし
' 返 却 値：なし
'--------------------------------------------------------------------------------
Function getSearchOption() As ClassSearchOptionInfo
    Dim searchOption As New ClassSearchOptionInfo
    'まとめてGrepシートオブジェクト
    Set searchOption.oConfSh = ThisWorkbook.Worksheets("まとめてGrep")
    '出力シートテンプレート
    Set searchOption.oTmpSh = ThisWorkbook.Worksheets("まとめてGrep_tmp")
    
    '検索対象文字列
    If searchOption.oConfSh.Range(searchListAdd).Value = "" Then
        MsgBox "検索対象文字列を入力してください。"
        GoTo Error
    End If
    '検索対象文字列
    If searchOption.oConfSh.Range(extentionListAdd).Value = "" Then
        MsgBox "対象拡張子を入力してください。"
        GoTo Error
    End If
    
    '英大文字・小文字の区別をする
    If xlOff = searchOption.oConfSh.CheckBoxes("isIgnoreCase").Value Then
        searchOption.isIgnoreCase = True
    Else
        searchOption.isIgnoreCase = False
    End If
    '単語単位で検索するチェックボックス取得
    searchOption.isBreak = searchOption.oConfSh.CheckBoxes("isBreak").Value
    '正規表現チェックボックス取得
    searchOption.isRegEx = searchOption.oConfSh.CheckBoxes("isRegEx").Value
    '結果のハイライト
    searchOption.isHylight = searchOption.oConfSh.CheckBoxes("isHylight").Value
    
    Call getSearchList(searchOption)

    '拡張子リスト
    Call getExtention(searchOption)
    
    Set getSearchOption = searchOption
    Exit Function
Error:
    Call term
    End
End Function

'--------------------------------------------------------------------------------
' 関 数 名：検索対象文字列取得
' 処理概要：検索対象文字列を配列に取得する
' 引  　数：ByRef searchOption As ClassSearchOptionInfo
' 返 却 値：
'--------------------------------------------------------------------------------
Function getSearchList(ByRef searchOption As ClassSearchOptionInfo)
    Dim startRow As Long '検索先頭行
    Dim endRow As Long '検索末尾行
    Dim col As Long '検索列
    Dim iRow As Long '行カウンタ
    Dim text As String '検索文字列
    Dim buf As String '検索文字列
    Dim metaChar As Variant
    Dim searchList() As String
    Dim srcSearchList() As String
    Dim idx As Integer
    Dim item As Variant
    
    metaChar = Array("\", "^", "$", "?", "*", "+", ".", "|", "{", "}", "[", "]", "(", ")")
    startRow = searchOption.oConfSh.Range(searchListAdd).Row
    col = searchOption.oConfSh.Range(searchListAdd).Column
    endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row
    
    '重複行の削除と書式再設定
    Call delDupliData(searchOption.oConfSh, startRow, endRow, col)
    '末尾行再取得
    endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row
    
    '--------------------------------
    '検索対象文字列取得
    '--------------------------------
    idx = 0
    For iRow = startRow To endRow
        text = searchOption.oConfSh.Cells(iRow, col)
        buf = searchOption.oConfSh.Cells(iRow, col)
        '正規表現OFFの場合はメタキャラクタをエスケープ
        If searchOption.isRegEx <> xlOn Then
            For Each item In metaChar
                buf = Replace(buf, item, "\" & item)
            Next
        End If
        '単語単位で検索する場合
        If searchOption.isBreak = xlOn Then
            buf = "\b" & buf & "\b"
        End If
        ReDim Preserve searchList(idx)
        ReDim Preserve srcSearchList(idx)
        searchList(idx) = buf
        srcSearchList(idx) = text
        idx = idx + 1
    Next iRow
    Call searchOption.setSearchList(searchList)
    Call searchOption.setSrcSearchList(srcSearchList)
End Function

'--------------------------------------------------------------------------------
' 関 数 名：検索対象ディレクトリ情報取得
' 処理概要：検索対象ディレクトリ情報を取得する
' 引  　数：ByVal oConfSh As Worksheet 設定ワークシート
' 返 却 値：ClassDirInfo
'--------------------------------------------------------------------------------
Function getTargetInfo(ByVal oConfSh As Worksheet) As ClassDirInfo()
    Dim startRow As Long '先頭行
    Dim endRow As Long '末尾行
    Dim col As Long '列
    
    Dim iRow As Long '行カウンタ
    Dim ext As String
    Dim buf As Variant '作業領域
    ReDim inf(0) As New ClassDirInfo
    Dim idx As Long
    
    startRow = oConfSh.Range(dirPathAdd).Row
    col = oConfSh.Range(dirPathAdd).Column
    endRow = oConfSh.Cells(Rows.Count, col).End(xlUp).Row
    
    idx = 0
    For iRow = startRow To endRow
        ReDim Preserve inf(idx)
        inf(idx).topDir = oConfSh.Cells(iRow, col)
        'パスの存在確認
        If "" = dir(inf(idx).topDir, vbDirectory) Then
            MsgBox iRow & " 行目の対象ディレクトリが存在しません。"
            GoTo Error
        End If
        '出力シート名
        inf(idx).outputSheetName = oConfSh.Cells(iRow, col + 1)
        '名前の定義
        inf(idx).name = oConfSh.Cells(iRow, col + 2)
        '名前を定義する列
        inf(idx).nameCols = oConfSh.Cells(iRow, col + 3)
        idx = idx + 1
    Next iRow
    getTargetInfo = inf
    Exit Function
Error:
    Call term
    End
End Function

'--------------------------------------------------------------------------------
' 関 数 名：重複データ削除
' 処理概要：重複データを削除する
' 引  　数：ByVal oConfSh As Worksheet シート
'               ByRef startRow As Long 先頭行
'               ByRef endRow As Long 末尾行
'               ByRef col As Long 列
' 返 却 値：String() 検索対象拡張子リスト
'--------------------------------------------------------------------------------
Function delDupliData(ByVal oConfSh As Worksheet, ByRef startRow As Long, ByRef endRow As Long, ByRef col As Long)
    Dim rng As Range
    Set rng = oConfSh.Range(oConfSh.Cells(startRow, col), oConfSh.Cells(endRow, col))
    With rng
        .RemoveDuplicates Columns:=1, Header:=xlNo
        .Borders.LineStyle = True
        .Font.name = "Meiryo UI"
        .Font.Size = 10
    End With
    Set rng = Nothing
End Function

'--------------------------------------------------------------------------------
' 関 数 名：検索対象拡張子取得
' 処理概要：検索対象拡張子を配列に取得する
' 引  　数：ByVal searchOption As ClassSearchOptionInfo
' 返 却 値：
'--------------------------------------------------------------------------------
Function getExtention(ByVal searchOption As ClassSearchOptionInfo)
    Dim startRow As Long '検索先頭行
    Dim endRow As Long '検索末尾行
    Dim col As Long '検索列
    
    Dim iRow As Long '行カウンタ
    Dim ext As String
    Dim buf As Variant '作業領域
    ReDim extentions(0) As String
    Dim idx As Long
    
    startRow = searchOption.oConfSh.Range(extentionListAdd).Row
    col = searchOption.oConfSh.Range(extentionListAdd).Column
    endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row
    
    '重複行の削除と書式再設定
    Call delDupliData(searchOption.oConfSh, startRow, endRow, col)
    '末尾行再取得
    endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row
    
    idx = 0
    For iRow = startRow To endRow
        ext = searchOption.oConfSh.Cells(iRow, col)
        If ext = "*" Then
            ext = ""
        Else
            If InStr(ext, ".") Then
                ext = Split(ext, ".")(1)
            End If
        End If
        ReDim Preserve extentions(idx)
        extentions(idx) = ext
        idx = idx + 1
    Next iRow
    Call searchOption.setExtentionList(extentions)
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

365

366

367

368

369

370

371

372

373

374

375

376

377

378

379

380

381

382

383

384

385

386

387

Option Explicit

'★★★★検索文字列リストの先頭アドレス

Const searchListAdd As String = "B10"

'★★★★対象拡張子先頭アドレス

Const extentionListAdd As String = "D10"

'★★★★対象ディレクトリ先頭アドレス

Const dirPathAdd As String = "G10"

'★★★★出力先先頭アドレス

Const startOutAdd As String = "A6"

'--------------------------------------------------------------------------------

' 関数名：まとめてGrep

' 処理概要：対象ディレクトリ配下にあるファイルから、検索対象文字列リストの文字列を検索する。

' 引　数：なし

' 返却値：なし

'--------------------------------------------------------------------------------

Public Sub ListGrep()

Dim searchOption As ClassSearchOptionInfo '検索オプション情報

Dim clsDirInfo() As ClassDirInfo '検索対象情報

Dim iDir As Long '検索ディレクトリ情報カウンタ

Dim nowResRow As Long '結果出力行の先頭行

Debug.Print Timer

'初期処理

Call init

'画面入力値取得

Set searchOption = getSearchOption()

'検索ディレクトリ情報取得

clsDirInfo = getTargetInfo(searchOption.oConfSh)

For iDir = 0 To UBound(clsDirInfo)

'出力シートを作成

searchOption.oTmpSh.Copy After:=ThisWorkbook.Worksheets(Worksheets.Count)

Set searchOption.oOutSh = ThisWorkbook.Worksheets(Worksheets.Count)

'出力シート名前変更

If clsDirInfo(iDir).outputSheetName <> "" Then

searchOption.oOutSh.name = clsDirInfo(iDir).outputSheetName

End If

'名前の定義

If clsDirInfo(iDir).name <> "" And clsDirInfo(iDir).nameCols <> "" Then

searchOption.oOutSh.Range(clsDirInfo(iDir).nameCols).name = clsDirInfo(iDir).name

End If

'出力位置

nowResRow = searchOption.oOutSh.Range(startOutAdd).Row

'Grep実行

Call doListGrep(clsDirInfo(iDir).topDir, searchOption, nowResRow)

'終期処理

Call term

Call searchOption.termClassSearchOptionInfo

Debug.Print Timer

MsgBox "(っ´ω`ｃ)おしまい"

End Sub

'--------------------------------------------------------------------------------

' 関数名：リストGrep処理

' 処理概要：各ディレクトリ配下のファイルごとにGrepを行う。

' 引　数：ByVal sTopPath As String

' ByVal searchOption As ClassSearchOptionInfo

' ByRef nowResRow As Long

' 返却値：なし

'--------------------------------------------------------------------------------

Function doListGrep(ByVal sTopPath As String, ByVal searchOption As ClassSearchOptionInfo, ByRef nowResRow As Long) As String()

'ファイルシステムオブジェクト

Dim oFSO As New FileSystemObject

'先頭ディレクトリオブジェクト

Dim topDir As Folder

'ディレクトリオブジェクト

Dim dir As Folder

'ファイルオブジェクト

Dim ofile As File

'先頭ディレクトリオブジェクト取得

Set topDir = oFSO.GetFolder(sTopPath)

'ディレクトリ配下のディレクトリパス名を取得する

For Each dir In topDir.SubFolders

If dir.Attributes <> Alias Then

Call doListGrep(dir.Path, searchOption, nowResRow)

End If

'ディレクトリ直下のファイル名を取得する

For Each ofile In oFSO.GetFolder(sTopPath).Files

'対象拡張子に該当するか確認する

If searchOption.isTargetExtention(oFSO.GetExtensionName(ofile.name)) Then

'文字列検索処理

Call searchFromFile(ofile, searchOption, nowResRow)

'該当した場合は次のファイルを検査

Exit For

End If

End Function

'--------------------------------------------------------------------------------

' 関数名：ファイルからの指定文字列検索

' 処理概要：ファイルを1行ずつ読み込み、リストの文字列があるか検索する

' 引　数：ByVal ofile As File

' ByVal searchOption As ClassSearchOptionInfo

' ByRef nowResRow As Long

' 返却値：なし

'--------------------------------------------------------------------------------

Function searchFromFile(ByVal ofile As File, ByVal searchOption As ClassSearchOptionInfo, ByRef nowResRow As Long)

Dim oFSO As New FileSystemObject 'ファイルシステムオブジェクト

Dim oStream As TextStream 'ストリーム

Dim buf, work As String '読み込み領域

Dim regEx As New regExp '正規表現オブジェクト

Dim regMc As MatchCollection 'Match Collection

Dim iMc As Integer 'マッチング箇所カウンタ

Dim regMatch As Match '正規表現matcher

Dim idx As Long '検索文字リストカウンタ

Dim result(8, 0) As String 'ヒットした情報の格納領域

Dim searchList() As String '検索文字列

Dim srcSeachList() As String '検索文字列ソース

'検索範囲 = 文字列全体を検索

regEx.Global = True

'英大文字・小文字の区別

regEx.IgnoreCase = searchOption.isIgnoreCase

searchList = searchOption.getSearchList

srcSeachList = searchOption.getSrcSearchList

Set oStream = oFSO.OpenTextFile(ofile.Path, ForReading, False)

Do While oStream.AtEndOfStream <> True

'1行読み込み

buf = oStream.ReadLine

'トリムして空行、コメント行（「/*」、「//」、「#」)の場合はスキップ

work = Replace(buf, vbTab, "")

work = Trim(work)

If work = "" Or Left(work, 2) = "/*" Or Left(work, 2) = "//" _

Or Left(work, 1) = "#" Then

GoTo Continue

End If

'検索文字リストとの比較

For idx = 0 To UBound(searchList)

regEx.Pattern = searchList(idx)

Set regMc = regEx.Execute(buf)

'ヒットした場合

If regMc.Count > 0 Then

result(0, 0) = "=N(INDIRECT(""R[-1]C"",FALSE))+1" 'No

result(1, 0) = ofile.Path 'パス

result(2, 0) = ofile.name 'ファイル名

result(3, 0) = oFSO.GetExtensionName(ofile.name) '拡張子

result(4, 0) = FileDateTime(ofile.Path) 'タイムスタンプ

result(5, 0) = FileLen(ofile.Path) 'サイズ

result(6, 0) = oStream.Line '行

result(7, 0) = srcSeachList(idx) '検索文字

result(8, 0) = buf '検索結果

searchOption.oOutSh.Range(searchOption.oOutSh.Cells(nowResRow, 1), searchOption.oOutSh.Cells(nowResRow, 9)).Value = _

WorksheetFunction.Transpose(result)

If searchOption.isHylight = xlOn Then

For iMc = 0 To regMc.Count - 1

Set regMatch = regMc.item(iMc)

With searchOption.oOutSh.Cells(nowResRow, "I").Characters(Start:=regMatch.FirstIndex + 1, Length:=regMatch.Length).Font

'★★★★色を赤にする

.Color = RGB(255, 0, 0)

End With

Next iMc

End If

nowResRow = nowResRow + 1

End If

Next idx

Continue:

Loop

oStream.Close

Set oFSO = Nothing

End Function

'--------------------------------------------------------------------------------

' 関数名：検索文字列リスト取得

' 処理概要：検索文字列を取得する

' 引　数：なし

' 返却値：なし

'--------------------------------------------------------------------------------

Function getSearchOption() As ClassSearchOptionInfo

Dim searchOption As New ClassSearchOptionInfo

'まとめてGrepシートオブジェクト

Set searchOption.oConfSh = ThisWorkbook.Worksheets("まとめてGrep")

'出力シートテンプレート

Set searchOption.oTmpSh = ThisWorkbook.Worksheets("まとめてGrep_tmp")

'検索対象文字列

If searchOption.oConfSh.Range(searchListAdd).Value = "" Then

MsgBox "検索対象文字列を入力してください。"

GoTo Error

End If

'検索対象文字列

If searchOption.oConfSh.Range(extentionListAdd).Value = "" Then

MsgBox "対象拡張子を入力してください。"

GoTo Error

End If

'英大文字・小文字の区別をする

If xlOff = searchOption.oConfSh.CheckBoxes("isIgnoreCase").Value Then

searchOption.isIgnoreCase = True

Else

searchOption.isIgnoreCase = False

End If

'単語単位で検索するチェックボックス取得

searchOption.isBreak = searchOption.oConfSh.CheckBoxes("isBreak").Value

'正規表現チェックボックス取得

searchOption.isRegEx = searchOption.oConfSh.CheckBoxes("isRegEx").Value

'結果のハイライト

searchOption.isHylight = searchOption.oConfSh.CheckBoxes("isHylight").Value

Call getSearchList(searchOption)

'拡張子リスト

Call getExtention(searchOption)

Set getSearchOption = searchOption

Exit Function

Error:

Call term

End

End Function

'--------------------------------------------------------------------------------

' 関数名：検索対象文字列取得

' 処理概要：検索対象文字列を配列に取得する

' 引　数：ByRef searchOption As ClassSearchOptionInfo

' 返却値：

'--------------------------------------------------------------------------------

Function getSearchList(ByRef searchOption As ClassSearchOptionInfo)

Dim startRow As Long '検索先頭行

Dim endRow As Long '検索末尾行

Dim col As Long '検索列

Dim iRow As Long '行カウンタ

Dim text As String '検索文字列

Dim buf As String '検索文字列

Dim metaChar As Variant

Dim searchList() As String

Dim srcSearchList() As String

Dim idx As Integer

Dim item As Variant

metaChar = Array("\", "^", "$", "?", "*", "+", ".", "|", "{", "}", "[", "]", "(", ")")

startRow = searchOption.oConfSh.Range(searchListAdd).Row

col = searchOption.oConfSh.Range(searchListAdd).Column

endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row

'重複行の削除と書式再設定

Call delDupliData(searchOption.oConfSh, startRow, endRow, col)

'末尾行再取得

endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row

'--------------------------------

'検索対象文字列取得

'--------------------------------

idx = 0

For iRow = startRow To endRow

text = searchOption.oConfSh.Cells(iRow, col)

buf = searchOption.oConfSh.Cells(iRow, col)

'正規表現OFFの場合はメタキャラクタをエスケープ

If searchOption.isRegEx <> xlOn Then

For Each item In metaChar

buf = Replace(buf, item, "\" & item)

End If

'単語単位で検索する場合

If searchOption.isBreak = xlOn Then

buf = "\b" & buf & "\b"

End If

ReDim Preserve searchList(idx)

ReDim Preserve srcSearchList(idx)

searchList(idx) = buf

srcSearchList(idx) = text

idx = idx + 1

Next iRow

Call searchOption.setSearchList(searchList)

Call searchOption.setSrcSearchList(srcSearchList)

End Function

'--------------------------------------------------------------------------------

' 関数名：検索対象ディレクトリ情報取得

' 処理概要：検索対象ディレクトリ情報を取得する

' 引　数：ByVal oConfSh As Worksheet 設定ワークシート

' 返却値：ClassDirInfo

'--------------------------------------------------------------------------------

Function getTargetInfo(ByVal oConfSh As Worksheet) As ClassDirInfo()

Dim startRow As Long '先頭行

Dim endRow As Long '末尾行

Dim col As Long '列

Dim iRow As Long '行カウンタ

Dim ext As String

Dim buf As Variant '作業領域

ReDim inf(0) As New ClassDirInfo

Dim idx As Long

startRow = oConfSh.Range(dirPathAdd).Row

col = oConfSh.Range(dirPathAdd).Column

endRow = oConfSh.Cells(Rows.Count, col).End(xlUp).Row

idx = 0

For iRow = startRow To endRow

ReDim Preserve inf(idx)

inf(idx).topDir = oConfSh.Cells(iRow, col)

'パスの存在確認

If "" = dir(inf(idx).topDir, vbDirectory) Then

MsgBox iRow & " 行目の対象ディレクトリが存在しません。"

GoTo Error

End If

'出力シート名

inf(idx).outputSheetName = oConfSh.Cells(iRow, col + 1)

'名前の定義

inf(idx).name = oConfSh.Cells(iRow, col + 2)

'名前を定義する列

inf(idx).nameCols = oConfSh.Cells(iRow, col + 3)

idx = idx + 1

Next iRow

getTargetInfo = inf

Exit Function

Error:

Call term

End

End Function

'--------------------------------------------------------------------------------

' 関数名：重複データ削除

' 処理概要：重複データを削除する

' 引　数：ByVal oConfSh As Worksheet シート

' ByRef startRow As Long 先頭行

' ByRef endRow As Long 末尾行

' ByRef col As Long 列

' 返却値：String() 検索対象拡張子リスト

'--------------------------------------------------------------------------------

Function delDupliData(ByVal oConfSh As Worksheet, ByRef startRow As Long, ByRef endRow As Long, ByRef col As Long)

Dim rng As Range

Set rng = oConfSh.Range(oConfSh.Cells(startRow, col), oConfSh.Cells(endRow, col))

With rng

.RemoveDuplicates Columns:=1, Header:=xlNo

.Borders.LineStyle = True

.Font.name = "Meiryo UI"

.Font.Size = 10

End With

Set rng = Nothing

End Function

'--------------------------------------------------------------------------------

' 関数名：検索対象拡張子取得

' 処理概要：検索対象拡張子を配列に取得する

' 引　数：ByVal searchOption As ClassSearchOptionInfo

' 返却値：

'--------------------------------------------------------------------------------

Function getExtention(ByVal searchOption As ClassSearchOptionInfo)

Dim startRow As Long '検索先頭行

Dim endRow As Long '検索末尾行

Dim col As Long '検索列

Dim iRow As Long '行カウンタ

Dim ext As String

Dim buf As Variant '作業領域

ReDim extentions(0) As String

Dim idx As Long

startRow = searchOption.oConfSh.Range(extentionListAdd).Row

col = searchOption.oConfSh.Range(extentionListAdd).Column

endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row

'重複行の削除と書式再設定

Call delDupliData(searchOption.oConfSh, startRow, endRow, col)

'末尾行再取得

endRow = searchOption.oConfSh.Cells(Rows.Count, col).End(xlUp).Row

idx = 0

For iRow = startRow To endRow

ext = searchOption.oConfSh.Cells(iRow, col)

If ext = "*" Then

ext = ""

Else

If InStr(ext, ".") Then

ext = Split(ext, ".")(1)

End If

ReDim Preserve extentions(idx)

extentions(idx) = ext

idx = idx + 1

Next iRow

Call searchOption.setExtentionList(extentions)

End Function

Option Explicit

Private Sub btnAddLink_Click()
    Call addHyperLink(Me)
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim rc As Long
    Dim iRow As Long
    Dim path As String
    Dim line As Long
    
    iRow = Target.Range.Row
    path = Me.Cells(iRow, "B")
    line = Me.Cells(iRow, "G")
    rc = Shell("D:\App\sakura\sakura.exe " & path & " -Y=" & line, vbNormalFocus)
End Sub