Excelでテキストボックスを検索するマクロ

2024年5月26日 15:16

Excelを使用していると、セル内のテキストは簡単に検索できますが、テキストボックスやオートシェイプ内のテキストは通常の検索機能では見つけることができません。検索してもほしいものがなかったのでChatGPTを使ってExcel内のテキストボックスやオートシェイプ内のテキストを検索するVBAを作ってみました。
検索すると検索結果がユーザーフォームに表示され、ダブルクリックで該当するシェイプを選択し、シート上の該当箇所に移動します。

マクロの概要

このマクロは、指定されたテキストを含む全てのテキストボックスやオートシェイプを検索し、見つかった場合に置換するかどうかをユーザーに確認するポップアップを表示します。さらに、グループ化された図形内のテキストや、異なるタイプの図形も処理します。検索結果がユーザーフォームに表示されます。ダブルクリックで該当するシェイプを選択し、シート上の該当箇所に移動します。

苦労したポイント

テキストボックスとオートシェイプの違い：テキストボックス内のテキストとオートシェイプ内のテキストは扱いが異なり、同じ方法で検索することはできない。
グループ化されたシェイプ：複数のシェイプをグループ化すると、その中に含まれる個々のシェイプへのアクセス方法が変わるらしい。
エラー処理：検索中に発生する可能性のあるエラーを適切に処理し、マクロが途中で停止しないようにする必要がありました。テキストが含まれないカギ接続などの回避。

これらの課題を克服するために、ChatGPTを活用してエラー処理や機能の実装を行いました。

フォームの作成手順

マクロを実行するためには、ユーザーフォームを作成する必要があります。以下に手順を示します。

VBAエディターを開く：
- Alt + F11キーを押してVBAエディターを開きます。
新しいユーザーフォームを追加：
- 挿入メニューからユーザーフォームを選択します。
- 作成されたフォームの名前を（frmResults）にしリストボックス（lstResults）を追加します。

フォームのコードを追加：
- 作成したフォームのコードウィンドウに以下のコードを追加します。

Public Sub InitializeResults(results As Collection)
    Dim i As Integer
    lstResults.Clear
    
    ' 検索結果をリストボックスに追加
    For i = 1 To results.Count
        lstResults.AddItem results(i)(0) & ": " & results(i)(1)
    Next i
End Sub

Private Sub lstResults_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim shp As Shape
    Dim ws As Worksheet
    Dim selectedPath As String

    ' リストボックスの選択が有効かどうかをチェック
    If lstResults.ListIndex <> -1 Then
        ' 選択された図形のパスを抽出
        selectedPath = GetShapeName(lstResults.value)
        ' 選択された図形を選択
        Set ws = ActiveSheet
        On Error Resume Next
        Set shp = GetShapeByPath(ws, selectedPath)
        On Error GoTo 0
        If Not shp Is Nothing Then
            CenterShapeInView ws, shp
            shp.Select
        Else
            MsgBox "選択された図形が見つかりません: " & selectedPath, vbExclamation
        End If
    Else
        MsgBox "有効な項目が選択されていません。", vbExclamation
    End If
End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

Function GetShapeName(item As String) As String
    ' 余分なスペースをトリムして名前を返す
    GetShapeName = Trim(Split(item, ": ")(0))
End Function

Function GetShapeByPath(ws As Worksheet, shpPath As String) As Shape
    Dim shp As Shape
    Dim parts() As String
    Dim i As Integer
    
    parts = Split(shpPath, " -> ")
    Set shp = ws.Shapes(parts(0))
    
    For i = 1 To UBound(parts)
        Set shp = shp.GroupItems(parts(i))
    Next i
    
    Set GetShapeByPath = shp
End Function

' 図形をビューの中央に移動する関数の例
Sub CenterShapeInView(ws As Worksheet, shp As Shape)
    Dim win As Window
    Set win = ws.Parent.Windows(1)
    
    Dim cell As Range
    Set cell = shp.TopLeftCell
    
    ' ウィンドウの高さと幅を取得
    Dim winHeight As Double, winWidth As Double
    winHeight = win.Height
    winWidth = win.Width
    
    ' セルの高さと幅を取得
    Dim cellHeight As Double, cellWidth As Double
    cellHeight = ws.Rows(cell.Row).Height
    cellWidth = ws.Columns(cell.Column).Width
    
    ' 中央にするためのスクロール位置を計算
    Dim scrollRow As Long, scrollCol As Long
    scrollRow = cell.Row - (winHeight / 2 / cellHeight)
    scrollCol = cell.Column - (winWidth / 2 / cellWidth)
    
    ' スクロール位置が負にならないように調整
    If scrollRow < 1 Then scrollRow = 1
    If scrollCol < 1 Then scrollCol = 1
    
    win.scrollRow = scrollRow
    win.scrollColumn = scrollCol
End Sub

マクロの実装手順

次に、テキストボックスやオートシェイプ内のテキストを検索するマクロを実装します。以下の手順で進めます。

標準モジュールを追加：
- 挿入メニューから標準モジュールを選択します。
- 新しいモジュールに以下のコードを追加します。

Dim searchResults As Collection

Sub SearchTextInTextBoxes()
    Dim ws As Worksheet
    Dim shp As Shape
    Dim searchText As String
    Dim found As Boolean
    
    ' ユーザーに検索するテキストを入力させる
    searchText = InputBox("検索するテキストを入力してください:", "テキストボックス内検索")
    
    If searchText = "" Then
        MsgBox "検索テキストが入力されていません。", vbExclamation
        Exit Sub
    End If
    
    ' アクティブなシートを設定
    Set ws = ActiveSheet
    found = False
    Set searchResults = New Collection
    
    ' シート内のすべてのシェイプをループ
    For Each shp In ws.Shapes
        SearchShape shp, searchText, found, ws
    Next shp
    
    ' 結果の表示
    If found Then
        ' ユーザーフォームを表示
        Load frmResults
        Call frmResults.InitializeResults(searchResults)
        frmResults.Show vbModeless
    Else
        MsgBox "検索テキストは見つかりませんでした。", vbInformation
    End If
End Sub

Sub SearchShape(shp As Shape, searchText As String, ByRef found As Boolean, ws As Worksheet)
    Dim subShp As Shape
    Dim result As Variant
    
    On Error Resume Next
    If shp.Type = msoGroup Then
        ' グループの場合、グループ内のシェイプを再帰的にチェック
        For Each subShp In shp.GroupItems
            SearchShape subShp, searchText, found, ws
        Next subShp
    ElseIf shp.Type = msoTextBox Or shp.Type = msoAutoShape Or shp.Type = msoFreeform Then
        ' 指定したテキストフレームにテキストがあるかどうかを返す
        If shp.TextFrame2.HasText = msoTrue Then
            ' シェイプ内のテキストを取得
            Dim shapeText As String
            shapeText = shp.TextFrame2.TextRange.Text
            
            ' シェイプ内の文字列から検索
            If InStr(shapeText, searchText) > 0 Then
                found = True
                ' シェイプのパス（親シェイプがある場合も含む）を含めて保存
                result = Array(GetShapePath(shp), shapeText)
                searchResults.Add result
            End If
        End If
    End If
    On Error GoTo 0
End Sub

Function GetShapePath(shp As Shape) As String
    Dim parentShp As Shape
    On Error Resume Next
    Set parentShp = shp.ParentGroup
    If Not parentShp Is Nothing Then
        GetShapePath = GetShapePath(parentShp) & " -> " & shp.Name
    Else
        GetShapePath = shp.Name
    End If
    On Error GoTo 0
End Function

マクロの実行方法

マクロの実行：
- Alt + F8キーを押してマクロダイアログを開き、SearchTextInTextBoxesを選択して実行をクリックします。
検索結果の確認：
- 検索結果がユーザーフォームに表示されます。ダブルクリックで該当するシェイプを選択し、シート上の該当箇所に移動します。