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

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

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

Excelの検索対象はセル内のみとなっており、図形内のテキストは検索対象外となっています。そのため、図形内の文字は人の目で探す・書き換えるということをしないといけません。めんどくさがりな筆者は2回以上の同じ作業はやりたくありません。

そこで以前「Excel 図形内のテキストを検索・置換する方法」という記事を書いて「RelaxTools Addin」を利用する方法を紹介しました。

こんな便利なツールがあるんだから、無理して自前でVBAを書くこともないんだけど、そこはやっぱりエンジニアとしてやってみたくなるじゃないですか。

しかも、これがなかなか奥深い。単純置換では複数図形は処理できないし、グループ化された図形も処理できなかった。

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

Sponsored Links


マクロの仕様

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

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

Sponsored Links

サンプルプログラム

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

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

'
' 関数名:図形文字列の置換
' 引数1:Shapes 図形オブジェクト
' 引数2:SearchText 検索文字列
' 引数3: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つはグループ化された図形です。

Excelでグループ化された図形を含む図形オブジェクトを配置

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

マクロを実行します。

マクロ(SearchAndReplaceOfShapeText)を実行する

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

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

置換後の文字列は「zzz」と入力してOKします。

置換後の文字列は「zzz」と入力してOKする

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

5件置換された

すると・・・・、

Excel図形オブジェクト内の「あああ」が「zzz」に変換された

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

Sponsored Links

まとめ

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

試してみると、、、

該当文字列のみ上書きするという方法で対応した

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

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

Sponsored Links

追記:複数シートに対応する方法

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

' 置換処理
'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」を設定すれば全シートを置換対象にできますよ。

おつかれさまでした。

この記事がお役に立ちましたら シェア をお願いいたします。

Sponsored Links