ＣｈａｔＧＰＴを使って作成したシートのセルとシェイプ内の文字列を対象にＧＲＥＰ検索してくれるコード

Option Explicit

'==== エントリーポイント ====
Public Sub GrepSearch()
    Dim pattern As String
    Dim isRegex As Boolean
    Dim isCaseSensitive As Boolean
    Dim scopeSel As Long '1:セル, 2:図形, 3:両方
    
    pattern = CStr(Application.InputBox(Prompt:="検索パターンを入力（正規表現可）", Title:="GREP検索", Type:=2))
    If pattern = "False" Then Exit Sub
    If Len(pattern) = 0 Then
        MsgBox "検索パターンが空です。", vbExclamation
        Exit Sub
    End If
    
    isCaseSensitive = (vbYes = MsgBox("大文字小文字を区別しますか？", vbYesNo + vbQuestion, "オプション"))
    isRegex = (vbYes = MsgBox("パターンを正規表現として扱いますか？" & vbCrLf & _
                              "（いいえ：プレーンテキスト検索）", vbYesNo + vbQuestion, "オプション"))
    
    scopeSel = ChooseScope()
    If scopeSel = 0 Then Exit Sub
    
    RunGrep pattern, isRegex, isCaseSensitive, scopeSel
End Sub

Private Function ChooseScope() As Long
    Dim ans As Variant
    ans = Application.InputBox( _
        Prompt:="検索対象を数値で指定してください:" & vbCrLf & _
                "1 = セルのみ" & vbCrLf & _
                "2 = 図形のみ" & vbCrLf & _
                "3 = 両方", _
        Title:="検索対象", Type:=1)
    If ans = False Then
        ChooseScope = 0
    ElseIf ans = 1 Or ans = 2 Or ans = 3 Then
        ChooseScope = CLng(ans)
    Else
        MsgBox "1～3のいずれかを入力してください。", vbExclamation
        ChooseScope = 0
    End If
End Function

'==== 本体 ====
Private Sub RunGrep(ByVal pattern As String, ByVal isRegex As Boolean, ByVal isCaseSensitive As Boolean, ByVal scopeSel As Long)
    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    
    If Not isRegex Then
        pattern = EscapeRegex(pattern)
    End If
    
    With re
        .pattern = pattern
        .Global = True
        .IgnoreCase = Not isCaseSensitive
    End With
    
    Dim targetBook As Workbook
    Set targetBook = ActiveWorkbook
    
    Dim ws As Worksheet
    Dim resultWS As Worksheet
    Dim startTime As Double
    startTime = Timer
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set resultWS = PrepareResultSheet(targetBook)
    Dim rowOut As Long: rowOut = 2
    
    For Each ws In targetBook.Worksheets
        If Not ws Is resultWS Then
            If scopeSel = 1 Or scopeSel = 3 Then
                rowOut = SearchCellsOnSheet(ws, re, resultWS, rowOut)
            End If
            If scopeSel = 2 Or scopeSel = 3 Then
                rowOut = SearchShapesOnSheet(ws, re, resultWS, rowOut)
            End If
        End If
    Next ws
    
    AutoFitResult resultWS
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "検索完了: " & (rowOut - 2) & " 件ヒット" & vbCrLf & _
           "経過時間: " & Format(Timer - startTime, "0.00") & " 秒", vbInformation
End Sub

'==== 結果シート作成 ====
Private Function PrepareResultSheet(targetBook As Workbook) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = targetBook.Worksheets("GREP結果")
    On Error GoTo 0
    If Not ws Is Nothing Then
        Application.DisplayAlerts = False
        ws.Delete
        Application.DisplayAlerts = True
    End If
    Set ws = targetBook.Worksheets.Add(After:=targetBook.Worksheets(targetBook.Worksheets.Count))
    ws.Name = "GREP結果"
    With ws
        .Range("A1:E1").Value = Array("種別", "シート名", "場所", "値（全文）", "一致スニペット")
        .Rows(1).Font.Bold = True
        .Columns("A:E").NumberFormatLocal = "@"
    End With
    Set PrepareResultSheet = ws
End Function

Private Sub AutoFitResult(ByVal ws As Worksheet)
    With ws
        .Columns("A:E").AutoFit
        .Activate
        .Range("A1").Select
    End With
End Sub

'==== セル検索 ====
Private Function SearchCellsOnSheet(ByVal ws As Worksheet, ByVal re As Object, ByVal outWS As Worksheet, ByVal rowOut As Long) As Long
    On Error Resume Next
    Dim rng As Range
    Set rng = ws.UsedRange
    Dim c As Range
    Dim text As String
    Dim matches As Object
    
    For Each c In rng.Cells
        text = CStr(GetCellText(c))
        If Len(text) > 0 Then
            Set matches = re.Execute(text)
            If matches.Count > 0 Then
                Dim snippet As String
                snippet = BuildSnippet(text, matches(0).FirstIndex, matches(0).Length)
                
                With outWS
                    .Cells(rowOut, 1).Value = "セル"
                    .Cells(rowOut, 2).Value = ws.Name
                    .Hyperlinks.Add Anchor:=.Cells(rowOut, 3), _
                        Address:="", SubAddress:="'" & ws.Name & "'!" & c.Address(False, False), _
                        TextToDisplay:=c.Address(False, False)
                    .Cells(rowOut, 4).Value = Left$(text, 32767)
                    .Cells(rowOut, 5).Value = snippet
                End With
                rowOut = rowOut + 1
            End If
        End If
    Next c
    
    SearchCellsOnSheet = rowOut
End Function

Private Function GetCellText(ByVal c As Range) As String
    On Error GoTo EH
    If IsError(c.Value2) Then
        GetCellText = "#ERROR"
    Else
        GetCellText = CStr(c.Value2)
    End If
    Exit Function
EH:
    GetCellText = ""
End Function

'==== 図形検索 ====
Private Function SearchShapesOnSheet(ByVal ws As Worksheet, ByVal re As Object, ByVal outWS As Worksheet, ByVal rowOut As Long) As Long
    Dim shp As Shape
    For Each shp In ws.Shapes
        rowOut = SearchShapeRecursive(ws, shp, re, outWS, rowOut, "")
    Next shp
    SearchShapesOnSheet = rowOut
End Function

Private Function SearchShapeRecursive(ByVal ws As Worksheet, ByVal shp As Shape, ByVal re As Object, _
                                      ByVal outWS As Worksheet, ByVal rowOut As Long, ByVal pathPrefix As String) As Long
    On Error Resume Next
    
    Dim currentPath As String
    currentPath = IIf(Len(pathPrefix) > 0, pathPrefix & "/", "") & shp.Name
    
    If shp.Type = msoGroup Then
        Dim gi As GroupShapes, i As Long
        Set gi = shp.GroupItems
        For i = 1 To gi.Count
            rowOut = SearchShapeRecursive(ws, gi.Item(i), re, outWS, rowOut, currentPath)
        Next i
        SearchShapeRecursive = rowOut
        Exit Function
    End If
    
    If shp.TextFrame2.hasText Or shp.TextFrame.hasText Then
        Dim tx As String
        If shp.TextFrame2.hasText Then
            tx = shp.TextFrame2.TextRange.text
        Else
            tx = shp.TextFrame.Characters.text
        End If
        
        If Len(tx) > 0 Then
            Dim matches As Object
            Set matches = re.Execute(tx)
            If matches.Count > 0 Then
                Dim snippet As String
                snippet = BuildSnippet(tx, matches(0).FirstIndex, matches(0).Length)
                With outWS
                    .Cells(rowOut, 1).Value = "図形"
                    .Cells(rowOut, 2).Value = ws.Name
                    .Cells(rowOut, 3).Value = currentPath
                    .Cells(rowOut, 4).Value = Left$(tx, 32767)
                    .Cells(rowOut, 5).Value = snippet
                End With
                rowOut = rowOut + 1
            End If
        End If
    End If
    
    SearchShapeRecursive = rowOut
End Function

Private Function BuildSnippet(ByVal text As String, ByVal startIdx As Long, ByVal matchLen As Long) As String
    Const CONTEXT As Long = 20
    Dim s As Long, e As Long
    s = Application.WorksheetFunction.Max(0, startIdx - CONTEXT)
    e = Application.WorksheetFunction.Min(Len(text), startIdx + matchLen + CONTEXT)
    BuildSnippet = IIf(s > 0, "…", "") & Mid$(text, s + 1, e - s) & IIf(e < Len(text), "…", "")
End Function

Private Function EscapeRegex(ByVal s As String) As String
    Dim specials As Variant
    specials = Array("\", ".", "^", "$", "*", "+", "?", "(", ")", "[", "]", "{", "}", "|")
    Dim i As Long
    For i = LBound(specials) To UBound(specials)
        s = Replace$(s, specials(i), "\" & specials(i))
    Next i
    EscapeRegex = s
End Function