この記事はリンク情報システムの「2020新春アドベントカレンダー TechConnect!」のリレー記事です。
TechConnect! は勝手に始めるアドベントカレンダーとして、engineer.hanzomon という勝手に作ったグループによってリレーされます。
リンク情報システムのFacebookはこちらから

はじめに

　業務中を効率良くするために使用するツール「Excel」。
　さらに機能を向上するためにVBAを学習がてら触ってみよう！と思い、現在に至ります。

構想

　さてさて、触るといっても何をしようかと...
　作成するなら業務とか日常で使えるものがいいなぁと考えながら働いていました。
　そんなある日！
　図形内(オートシェイプ)の文字を検索しても、検出されないということがありました。

　ご存じの通りのExcelにはとても便利な機能「検索・置換」があります。しかし、デフォルトの検索対象はセル内のみであり、残念なことに図形内の文字は検出してくれません...
　このままではExcelの資料で、図形内に書き込んだ文字を変更する時に変更漏れ等の人為的ミスが生じるかもしれません。
　そのような悩み・問題を少しでも無くしたいと思い、作成しました。

やりたいこと

やりたいことはただ2つ！
・Excelから図形内の文字を検索
・検索した文字を置換

ソースコード

　以下、作成したソースコードとなります。
　コピペすれば動くはずです！

Option Explicit
'ポップアップの名前
Private Const TITLE_SEARCH_SHAPE_TEXT As String = "オートシェイプ検索"

'@brief  : 文字検索関数
'@return : なし
Public Sub searchShapeText()

    Dim sheet As Worksheet          'ワークシート
    Dim searchWord As String        '検索ワード

    '検索ワード入力ポップアップを表示する
    searchWord = InputBox("検索したいワードを入力して下さい", TITLE_SEARCH_SHAPE_TEXT)

    If searchWord = "" Then
        GoTo ExitSub
    End If

     '対象のワークシートを現在開いているシートとする
    Set sheet = ActiveSheet

    '検索ワードが見つからない場合に出力
    If Not (searchReplaceShapeText(sheet.Shapes, searchWord)) Then
        MsgBox "「" & searchWord & "」が見つかりません", vbExclamation, TITLE_SEARCH_SHAPE_TEXT
    End If

ExitSub:
End Sub


'@brief : 図形内検索置換関数
'@param : worksheetObject Worksheetオブジェクト
'@param : searchWord      検索文字
'@return: searchReplaceShapeText 処理継続判定
Private Function searchReplaceShapeText(ByVal worksheetObject As Object, ByVal searchWord As String) As Boolean

    Dim targetShape  As Shape       'ワークシート内の図形
    Dim shapeText   As String       '図形内の文字
    Dim discoveryWord As Long       '検索ワード発見位置
    Dim replaceWord As String       '置換後の文字
    Dim replacePopupMsg As String   '置換ポップアップメッセージ
    Dim ret As Boolean              '処理継続判定
    Dim searchWordCnt As Long: searchWordCnt = 1 '図形内検索ワード数

    ret = False

    'ワークシートに図形が存在する間ループ
    For Each targetShape In worksheetObject

        'クループ化された図形の時
        If (targetShape.Type = msoGroup) Then

            If (searchReplaceShapeText(targetShape.GroupItems, searchWord)) Then
                ret = True
                GoTo ExitFunction
            End If

        'コメントの時
        ElseIf (targetShape.Type = msoComment) Then
            GoTo CONTINUE

        Else
            '指定したテキストフレームにテキストがあるかどうかを返す
            If (targetShape.TextFrame2.HasText = msoTrue) Then

                '図形内のテキストを取得
                shapeText = targetShape.TextFrame2.TextRange.Text

                '図形内の文字列から検索
                discoveryWord = InStr(shapeText, searchWord)

                '検索ワードが見つかったとき、置換の処理を行う
                If (discoveryWord > 0&) Then

                    'ウィンドウを図形の位置にスクロール
                    ActiveWindow.ScrollRow = targetShape.TopLeftCell.Row
                    ActiveWindow.ScrollColumn = targetShape.TopLeftCell.Column

                    Do While (discoveryWord > 0&)

                         'テキスト範囲選択を解除するため、カレントセルを選択する
                        targetShape.TopLeftCell.Select

                        targetShape.TextFrame2.TextRange.Characters(discoveryWord, Len(searchWord)).Select

                        replacePopupMsg = "置換する場合、入力してください。" & vbCr & vbCr & "置換前 : " & searchWord & vbCr & "置換後"

                        ' 置換入力メッセージを出力する
                        replaceWord = InputBox(replacePopupMsg, "置換")

                        If replaceWord = "" Then
                          ret = True
                          GoTo CONTINUE
                        End If

                        '図形内の文字列を置換する
                        targetShape.TextFrame2.TextRange.Text = Replace(shapeText, searchWord, replaceWord, 1, searchWordCnt)
                        targetShape.TopLeftCell.Select


                        'もう一度検索・置換するのか
                        If (MsgBox("continue?", vbQuestion Or vbOKCancel, TITLE_SEARCH_SHAPE_TEXT) <> vbOK) Then
                            ret = True

                            GoTo CONTINUE

                        '同じ図形内で文字検索
                        Else
                            discoveryWord = InStr(discoveryWord + 1&, shapeText, searchWord)
                        End If

                        searchWordCnt = searchWordCnt + 1

                    Loop

                    GoTo CONTINUE
                End If
            End If
        End If
CONTINUE:
    Next

ExitFunction:
    searchReplaceShapeText = ret
ExitSub:
End Function

使用方法

今回は例としてワークシート上に【検索・置換ボタン】を作成しました。
(ショートカットキーやクイックアクセスツールバーに登録すると使いやすいかと思います。)

検索

　1.検索・置換ボタンを押します。
　2.検索ワードを入力します。
　・Enterキーもしくは[OK]をクリックすると検索が開始します。
　・[×]もしくは[キャンセル]をクリックすると終了します。
　・図形内に無い文字を入力すると警告文が出力され終了します。

　※セル内の文字は検索対象ではありません


検索結果/置換ワード入力

　1.検索ワードが見つかると対象の図形にジャンプし、置換のメッセージが表示されます。
　2.置換後のボックスに置換後の文字を入力します。
　・Enterキーもしくは[OK]をクリックすると図形内の対象の文字が置換されます。
　・[×]もしくは[キャンセル]をクリックすると終了します。

再検索

　1.置換完了後に再度同じワードを検索・置換するかを問うメッセージが出力されます。
　・Enterキーもしくは[OK]をクリックすると検索が開始します。
　・[×]もしくは[キャンセル]をクリックすると終了します。
　2-1.検索文字がさらに見つかった場合は「検索結果/置換ワード入力」の状態に戻ります。
　2-2.見つからない場合は警告文が出力され終了します。