ちょっと生きづらさを抱えた人へ、気持ちを楽にするためのお手紙です。

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

SHARE

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

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

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

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

******** 追記 ********
ご指摘いただきまして、謎に入っていたバグがあったので修正しました。
ありがとうございます！
**********************

ダウンロードはこちら

ExcelVBA参照設定_01

ExcelVBA参照設定_02

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

'--------------------------------------------------------------------------------
' 関 数 名：初期処理
' 処理概要：初期設定を行う
' 引  　数：なし
' 返 却 値：なし
'--------------------------------------------------------------------------------
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)
            '該当した場合は次のファイルを検査
        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

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

 

参考：

作業を効率化させるExcel VBA Tips集 様
指定パス配下にファイルにGrepみたいなことやってみるツール

Office デベロッパーセンター
Application.PathSeparator プロパティ (Excel)

エクセルの神髄 様
マクロVBAの高速化・速度対策の具体的手順と検証

1 COMMENT

コメントを残す

メールアドレスが公開されることはありません。 ※ が付いている欄は必須項目です

CAPTCHA


前の記事

【Excel】重複するセルの先頭を抽出する

次の記事

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