VBA 図形内テキストを一括で検索・置換する方法

図形内テキストを検索・置換するマクロの仕様はこんな感じです。

• 検索用入力ダイアログを表示して検索する文字を入力する。
• 置換用入力ダイアログを表示して置換する文字を入力する。
• シート内のすべての図形内テキストにある置換対象文字を置換文字に置き換える。
• グループ化されている図形も対象とする。

下記を標準モジュールへ貼り付けてください。

Option Explicit

Private ReplaceCount As Long   ' 置換件数

'
' 関数名：図形内文字列の検索と置換
' 引数  ：なし
' 戻り値：なし
'
Public Sub SearchAndReplaceOfShapeText()

  Dim SearchText As String    ' 検索する文字列
  Dim ReplaceText As String     ' 置換後の文字

  ' 検索文字列入力用InputBoxを表示
  SearchText = InputBox("検索する文字列")
  
  ' 検索文字列の入力がなければ処理終了
  If SearchText = "" Then
    Exit Sub
  End If
  
  ' 置換文字列入力用InputBoxを表示
  If ReplaceText = "" Then
    ReplaceText = InputBox("置換後の文字列")
  End If

  ' 置換処理
  ReplaceCount = 0
  If ReplaceOfShapeText(ActiveSheet.Shapes, SearchText, ReplaceText) Then
    MsgBox ReplaceCount & " 件を置換しました。", vbInformation
  Else
    MsgBox "置換対象が見つかりません。", vbExclamation
  End If

End Sub

'
' 関数名：図形文字列の置換
' 引数１：Shapes 図形オブジェクト
' 引数２：SearchText 検索文字列
' 引数３：ReplaceText 置換文字列
' 戻り値：True：置換成功、False：置換対象なし
'
Private Function ReplaceOfShapeText(ByRef Shapes As Object, ByRef SearchText As String, ByRef ReplaceText As String) As Boolean

  Dim Ret As Boolean        ' 処理結果
  Dim Shape  As Shape       ' 図形オブジェクト
  Dim ShapeText As String   ' 図形内の文字列
  Dim Pos As Long           ' 文字列位置

  ' 初期値設定
  Ret = False

  ' シート内の図形を検索
  For Each Shape In Shapes

    ' グループ化された図形の場合
    If Shape.Type = msoGroup Then
      ' 再帰呼び出し
      If ReplaceOfShapeText(Shape.GroupItems, SearchText, ReplaceText) Then
        Ret = True
        ReplaceCount = ReplaceCount + 1
        Exit For
      End If

    ' テキストフレームに文字列がある場合
    ElseIf Shape.TextFrame2.HasText = msoTrue Then

      ' 図形内の文字列を置換
      Do While (1)
      
        ' 図形内の文字列を取得
        ShapeText = Shape.TextFrame2.TextRange.text

        ' 図形内の文字列から検索文字列位置を取得
        Pos = InStr(ShapeText, SearchText)

        ' 検索文字列が見つからない場合は処理終了
        If Pos = 0& Then
          Exit Do
        End If

        ' 検索文字列を置換する
        Shape.TextFrame2.TextRange.text = Replace(ShapeText, SearchText, ReplaceText)
        Ret = True
        ReplaceCount = ReplaceCount + 1
      Loop
    End If
  Next

  ' 処理結果を返す
  ReplaceOfShapeText = Ret

End Function

簡単に説明すると、検索文字列入力用のインプットボックスと置換文字列入力用のインプットボックスを表示して、図形オブジェクト分ループして図形内の文字列を探して置き換えるって処理です。ポイントは、グループ化された図形は「Shape.Type = msoGroup」となるので、再帰呼び出しでグループ化された図形を引き渡しています。

早速、動作検証してみましょう。

下図のような図形オブジェクトを配置します。1つはグループ化された図形です。

この中の「あああ」を「ｚｚｚ」に変換してみましょう。

マクロを実行します。

検索する文字列は「あああ」と入力してOKします。

すると下記のメッセージが表示されます。

すると・・・・、

おおおー、図形内の文字列が置換されてるー！！

VBAで図形内テキストを検索・置換する方法を紹介しました。

今のところ筆者の仕事の中では使うことがないのですが、どなたかのお役にたてればうれしいですね。

サンプルは こちら に置いてあります。利用は自己責任でお願いします。不具合などあればコメントください。

・VBAで図形内テキストを検索・置換する方法のサンプル

上の方法だと、太字や文字色を変えていた場合など、フォント設定に影響が出ることがわかりました。

この原因は Shape.TextFrame2.TextRange.text に対して置換後の文字列を上書きしているためです。なので該当部分を下記のように変更してフォント設定を維持しましょう。

' 検索文字列を置換する
'Shape.TextFrame2.TextRange.text = Replace(ShapeText, SearchText, ReplaceText ' ←これではフォント設定が維持できない。
Shape.TextFrame.Characters(Pos, Len(SearchText)).text = ReplaceText

Shape.TextFrame.Characters は開始位置と終了位置を指定できます。これを使って該当文字列のみ上書きするという方法で対応できます。セルを編集状態にして該当文字列を選択して書き換えるというと伝わるでしょうか。

試してみると、、、

おおおー、フォント設定は維持されたまま置換できたー＾＾

サンプルも変更しておきましたのでご利用ください。

複数シートを検索して置換できる方法が知りたい、とのコメントをいただきましたので追記します。置換処理部分をコメントして、下記のように書き換えてください。

' 置換処理
'ReplaceCount = 0
'If ReplaceOfShapeText(ActiveSheet.Shapes, SearchText, ReplaceText) Then
'  MsgBox ReplaceCount & " 件を置換しました。", vbInformation
'Else
'  MsgBox "置換対象が見つかりません。", vbExclamation
'End If

' 全シート置換処理
Dim TargetSheet As Worksheet
ReplaceCount = 0
For Each TargetSheet In ThisWorkbook.Worksheets
  ReplaceOfShapeText TargetSheet.Shapes, SearchText, ReplaceText
Next
If ReplaceCount > 0 Then
  MsgBox ReplaceCount & " 件を置換しました。", vbInformation
Else
  MsgBox "置換対象が見つかりません。", vbExclamation
End If

「For Each TargetSheet In ThisWorkbook.Worksheets ... Next」を使うことで全シートをループできます。引数に「TargetSheet.Shapes」を設定すれば全シートを置換対象にできますよ。