Excel Grepツールの作成

VBA
2021.05.16

背景

どうしてExcel Grepツールを使う必要でしょうか。
ITの現場では設計と実装を分けられています。
設計は要件定義、基本設計、詳細設計などありますが、
一般的にExcelを使って、ドキュメントを作っている現場が多いのです。

なので、例えばテーブルの項目桁数を変更する場合、影響範囲はどれほどあるか知りたいですよね。
影響範囲を抑えた上で仕様変更のスコープを把握し、見積したり、要員計画を作る必要があります。

Excel Grepツールを使わないと、設計書を一本一本開いて、纏めるしかないですよね。
非常に非効率な機械作業に苦労する必要がないので、今回のExcel Grepツールを作る背景でした。

ネット上の知恵を借りれるか

事例①

Excel VBAでExcelファイルをGrepする - Qiita
Source ExcelGrep (gist on GitHub) Downlo...
qiita.com

↑上記提供されているツールはExcel Grepできますが、速度が非常に遅かった。あまり使えないのではないかと諦めた。
中身を確認しましたが、Cell単位でループしているので、入力セルの数が多ければ多いほど遅いです。
証拠は下記の赤字の部分です。

Private Sub SearchSheet(Sheet As Worksheet)
    If ShouldSearch = False Then Exit Sub
    
    Dim TargetRange As Range
    Dim Cell        As Range

    'Search Cells
    Set TargetRange = Sheet.UsedRange.Cells
    For Each Cell In TargetRange
        DoEvents
        Call DisplayStatus(Sheet.Parent.FullName)
        
        If Cell.Value <> "" Then
            If REG.Test(Cell.Value) Then
                Call ProcessCell(Cell)
            End If
        End If
    Next
    
    'Search Shapes
    Dim objShape As Shape
    For Each objShape In Sheet.Shapes
        DoEvents
        Call DisplayStatus(Sheet.Parent.FullName)
        
        If HasTextFrameCharactersText(objShape) Then
            If REG.Test(objShape.TextFrame.Characters.Text) Then
                Call ProcessShape(objShape)
            End If
        End If
    Next
End Sub

　このツールの良いところは下記２点あります。
・部品がクラスモジュール化している。使いやすくなる。
・検索中に中止できる。検索ループの中にグローバル変数を使って、中止するかどうか判定してる。

事例②

VBAでExcelファイルをGrep検索するマクロを書いてみた ｜ Website-Note
この記事を読むのに必要な時間は約 6 分です。 たくさんのファイルの中身をまとめて検索するには、Grepですよね。   サクラエディタや秀丸エディタなど、エディタに付いている機能の１つです。   でも …
website-note.net

↑こちらのツールは検索スピードが速いです。なぜなら、Excel検索の部品を使って、実行している。
ただし、ツール自体のダウンロード先を乗ってくれなかったので、ソースを理解して、ツールを作る必要があった。ツールの雛形を変更して、作り直しました。ダウンロード先も公開します。
使う必要な方は最後の成果物からダウンロードください。

■元のツールを基づいて、変更した内容を記載する。
①雛型変更
検索結果は常に別シートを作る。シート名は「検索キーワード+Grep」の形を設定している。

'Grepメイン関数
Public Sub grepMain()
    Dim bErrFlag As Boolean
    bErrFlag = False
    
    sFilePathRoot = ThisWorkbook.Sheets(1).Range("C2").Value
    sKeyWord = ThisWorkbook.Sheets(1).Range("C3").Value

    'シート名を作る    
    STR_GREP_SHEET_NAME = sKeyWord & "Grep"
    
    ThisWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = STR_GREP_SHEET_NAME
    
    'ヘッダーのセルの色を設定
    Range("B2:G2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599993896298105
        .PatternTintAndShad’e = 0
    End With
    
    '検索結果シートのヘッダーを作る
    Range("B2").Value = "No."
    Range("C2").Value = "パス"
    Range("D2").Value = "ファイル名"
    Range("E2").Value = "シート名"
    Range("F2").Value = "セル位置"
    Range("G2").Value = "セル内容"


②検索ループ不具合を修正した
キーワードで検索し、セルの内容が全く同じの場合、シート内の検索が終了となってしまう。
例えば、セルA2.value= 加入者コードとセルB5.value=加入者コードの場合に、セルA2の内容しか出力しない問題があり、修正しました。

シート内容の検索終了条件は同じセル内容ではなく、一つ目のセルに戻ってきたら終了にする。

■修正前

'Excelのシート内をGrep
Private Sub grepExcelSheet(ByVal sFilePath As String, ByVal sTmpPath As String, ByVal lSheetNo As Long)
 
    Dim lCellRow As Long, lCellCol As Long
    Dim rFoundCell As Range, rFoundFirstCell As Range
    Dim rEndRange As Range
    Dim rTmpFoundCell As Range
    Dim sTmpSheetName As String
    
 
    With Workbooks(sTmpPath).Sheets(lSheetNo)
        
        'シート内1件目に見つかったセルを取得
        Set rTmpFoundCell = .Cells.Find(What:=sKeyWord, LookAt:=xlPart)
        
        '見つからなかったら関数を抜ける
        If rTmpFoundCell Is Nothing Then Exit Sub
        
        'シート名を取得
        sTmpSheetName = .Name
        
        '最初に見つかったセル情報を保持
        Set rFoundFirstCell = rTmpFoundCell
        
        Do
        
            '見つかったセルの情報を一覧に記載
            Call outputCellInfo(sTmpPath, sFilePath, sTmpSheetName, rTmpFoundCell)
        
            'シート内2件目以降に一致したやつ
            Set rTmpFoundCell = .Cells.FindNext(rTmpFoundCell)
        
        '見つかったセルが最初に見つかったセルと異なる間ループ
        Loop While rTmpFoundCell <> rFoundFirstCell
    
    End With
 
End Sub

■修正後

'Excelのシート内をGrep
Private Sub grepExcelSheet(ByVal sFilePath As String, ByVal sTmpPath As String, ByVal lSheetNo As Long)

    Dim lCellRow As Long, lCellCol As Long
    Dim rFoundCell As Range, rFoundFirstCell As Range
    Dim rEndRange As Range
    Dim rTmpFoundCell As Range
    Dim sTmpSheetName As String
    

    With Workbooks(sTmpPath).Sheets(lSheetNo)
        
        'シート内1件目に見つかったセルを取得
        Set rTmpFoundCell = .Cells.Find(What:=sKeyWord, LookAt:=xlPart)
        
        '見つからなかったら関数を抜ける
        If rTmpFoundCell Is Nothing Then Exit Sub
        
        'シート名を取得
        sTmpSheetName = .Name
        
        '最初に見つかったセル情報を保持
        Set rFoundFirstCell = rTmpFoundCell
        
        Do
        
            '見つかったセルの情報を一覧に記載
            Call outputCellInfo(sTmpPath, sFilePath, sTmpSheetName, rTmpFoundCell)
        
            'シート内2件目以降に一致したやつ
            Set rTmpFoundCell = .Cells.FindNext(rTmpFoundCell)
        
        '見つかったセルが最初に見つかったセルと異なる間ループ
        Loop While rTmpFoundCell.Row <> rFoundFirstCell.Row And rTmpFoundCell.Column <> rFoundFirstCell.Columns
    
    End With

End Sub

③検索対象ファイルの拡張子を変更

■修正前

    'Dirで見つかったファイル名を取得
    sTmpPath = Dir(sFilePath & "*.xls")

■修正後

    'Dirで見つかったファイル名を取得
    sTmpPath = Dir(sFilePath & "*.xls*")

成果物

■ダウンロード先
https://github.com/ljsdl/VBA-for-Project-Management/raw/main/7_ExcelGrep.xlsm

Option Explicit

Public STR_GREP_SHEET_NAME As String
Public sMsgString As String
Public sFilePathRoot As String
Public sKeyWord As String
Public lcnt As Long


'Grepメイン関数
Public Sub grepMain()
    Dim bErrFlag As Boolean
    bErrFlag = False
    
    sFilePathRoot = ThisWorkbook.Sheets(1).Range("C2").Value
    sKeyWord = ThisWorkbook.Sheets(1).Range("C3").Value
        
    STR_GREP_SHEET_NAME = sKeyWord & "Grep"
    
    ThisWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = STR_GREP_SHEET_NAME
    
    'ヘッダーひながた作成
    Range("B2:G2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    
    Range("B2").Value = "No."
    Range("C2").Value = "パス"
    Range("D2").Value = "ファイル名"
    Range("E2").Value = "シート名"
    Range("F2").Value = "セル位置"
    Range("G2").Value = "セル内容"
    

    'エラーチェック
    bErrFlag = inputCheck

    If bErrFlag = False Then

        '描画をいったんオフ
        Application.ScreenUpdating = False
    
        '一覧をクリア
        Call clearCells
    
        If Right(sFilePathRoot, 1) <> "\" Then
            sFilePathRoot = sFilePathRoot & "\"
        
        End If
    
        lcnt = 3
        
        'ExcelファイルのGrep
        Call openExcelFiles(sFilePathRoot)
        
        '罫線を引く
        Call addLines
        
        '描画をオン
        Application.ScreenUpdating = True
        
        sMsgString = "Grepが完了しました！！"
    
    End If
    
    'メッセージ出力
    MsgBox sMsgString
    
End Sub


'入力内容チェック
Private Function inputCheck() As Boolean
    inputCheck = False
    If sKeyWord = "" Then
        sMsgString = "キーワードが入力されていません"
        inputCheck = True
    End If
End Function


'指定したフォルダ内のエクセルファイルを全検索
Private Sub openExcelFiles(ByVal sFilePath As String)
    
    Dim lSheetNo As Long
    Dim sTmpPath As String
    Dim oFSO As Object
    
    If Right(sFilePath, 1) <> "\" Then
        sFilePath = sFilePath & "\"
    End If
    
    'Dirで見つかったファイル名を取得
    sTmpPath = Dir(sFilePath & "*.xls*")
    
    '同じフォルダ内でエクセルファイルが見つかる限り検索
    Do While sTmpPath <> ""
        
        '読み取り専用、更新なしで開く
        Workbooks.Open sFilePath & sTmpPath, UpdateLinks:=0, ReadOnly:=1
        
            '全シートループ
            For lSheetNo = 1 To Worksheets.Count
            
                'シート内をGrep
                Call grepExcelSheet(sFilePath, sTmpPath, lSheetNo)
                
            Next lSheetNo
        
        Workbooks(sTmpPath).Close
        
        sTmpPath = Dir()
    
    Loop
    
    'この関数自身を呼び出して、サブフォルダも再帰的に検索
    With CreateObject("Scripting.FileSystemObject")
        For Each oFSO In .GetFolder(sFilePath).SubFolders
            Call openExcelFiles(oFSO.Path)
        Next oFSO
    End With
    
    Set oFSO = Nothing

End Sub

'Excelのシート内をGrep
Private Sub grepExcelSheet(ByVal sFilePath As String, ByVal sTmpPath As String, ByVal lSheetNo As Long)

    Dim lCellRow As Long, lCellCol As Long
    Dim rFoundCell As Range, rFoundFirstCell As Range
    Dim rEndRange As Range
    Dim rTmpFoundCell As Range
    Dim sTmpSheetName As String
    

    With Workbooks(sTmpPath).Sheets(lSheetNo)
        
        'シート内1件目に見つかったセルを取得
        Set rTmpFoundCell = .Cells.Find(What:=sKeyWord, LookAt:=xlPart)
        
        '見つからなかったら関数を抜ける
        If rTmpFoundCell Is Nothing Then Exit Sub
        
        'シート名を取得
        sTmpSheetName = .Name
        
        '最初に見つかったセル情報を保持
        Set rFoundFirstCell = rTmpFoundCell
        
        Do
        
            '見つかったセルの情報を一覧に記載
            Call outputCellInfo(sTmpPath, sFilePath, sTmpSheetName, rTmpFoundCell)
        
            'シート内2件目以降に一致したやつ
            Set rTmpFoundCell = .Cells.FindNext(rTmpFoundCell)
        
        '見つかったセルが最初に見つかったセルと異なる間ループ
        Loop While rTmpFoundCell.Row <> rFoundFirstCell.Row And rTmpFoundCell.Column <> rFoundFirstCell.Columns
    
    End With

End Sub


'キーワードを含むセルの情報をアウトプット
Private Sub outputCellInfo(ByVal sTmpPath As String, ByVal sFilePath As String, ByVal sTmpSheetName As String, _
                                                                            ByVal rFoundCell As Range)
                                                                            
    With ThisWorkbook.Sheets(STR_GREP_SHEET_NAME)
        
        'No
        .Cells(lcnt, 2).Value = lcnt - 2
        
        'パス
        .Cells(lcnt, 3).Value = sFilePath
        
        'ファイル名
        .Cells(lcnt, 4).Value = sTmpPath
        
        'シート名
        .Cells(lcnt, 5).Value = sTmpSheetName
        
        'セルの位置
        .Cells(lcnt, 6).Value = convertRange(rFoundCell.Column) & rFoundCell.Row
        
        'キーワードを含むセルの内容
        .Cells(lcnt, 7).Value = rFoundCell.Value
        
    End With

    '次の行に繰り上げる
    lcnt = lcnt + 1

End Sub


'セルの位置を変換
Private Function convertRange(ByVal lCol As Long) As String
    convertRange = ""
    
    Dim lTmpCol As Long
    Dim lBuf As Long
    Dim sAsc As Long
    sAsc = 64
    
    If Len(lCol) = 0 Then Exit Function
    
    lTmpCol = lCol
    
    '1桁目を変換
    lBuf = sAsc + lTmpCol Mod 26
        
    convertRange = Chr(lBuf)
    
    lTmpCol = lTmpCol \ 26
    
    '2桁目を変換
    If lTmpCol Mod 26 >= 1 Then
        
        lBuf = sAsc + lTmpCol Mod 26
        convertRange = Chr(lBuf) & convertRange
        
    End If
    
    '3桁目を変換
    If lTmpCol \ 26 >= 1 Then
    
        lBuf = sAsc + lTmpCol \ 26
        convertRange = Chr(lBuf) & convertRange
        
    End If

End Function


'罫線を引く
Private Sub addLines()
    
    Dim lRow As Long
    
    '2行目以降を選択
    lRow = ThisWorkbook.Sheets(STR_GREP_SHEET_NAME).Cells(Rows.Count, 2).End(xlUp).Row
    
    '0件の場合は罫線を引かない
    If lRow < 2 Then Exit Sub
    
    Range("B2:G" & lRow).Select
    
    '最初に通常の罫線を引く
    With Selection.Borders()
    
        .LineStyle = xlContinuous
        .Weight = xlThin
    
    End With
    
    '内側の横方向の罫線だけ点線にする
    With Selection.Borders(xlInsideHorizontal)
    
        .LineStyle = xlContinuous
        .Weight = xlHairline
    
    End With
    
    Range("A1").Select
    
End Sub

'セルをクリア
Private Sub clearCells()

    '3行以下ならクリアしない
    If ActiveCell.SpecialCells(xlLastCell).Row < 3 Then
        Exit Sub
    End If

    '3行目以降をクリア
    Range("B3", ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Borders().LineStyle = xlLineStyleNone
    Selection.ClearFormats
    Selection.ClearContents
    Range("A1").Select
        
End Sub

コメント

タイトルとURLをコピーしました