エクセルのオートシェイプ内のテキスト置換

質問

エクセル2007を使用しています。
オートシェイプ内のテキストを一括して置換したいと考えております。
便利なソフトやVBAを試してみたのですが、元の文字色が変わってしまいます。
オートシェイプ内の文字色は2，3色使用しており、その色を保持したまま、一部の文字だけ置換したいのです。そういったことは可能でしょうか。ちなみに置換したい文字色は1色です。
よろしくお願いいたします。

回答No.3

real beatin（@realbeatin） · ベストアンサー

＃１です。

すみません。未完のものをあげてしまっていました。
以下、差し替えてください。
失礼しました。

' ' /// 実行マクロ /// ReplaceTextFrameCharCaption の使用例
Sub Re8980222w()　'　アクテイブシートを指定
　　ReplaceTextFrameCharCaption ActiveSheet, "検索する文字列", "置換する文字列"
End Sub
Sub Re8980222w2()　'　シート名を指定
　　ReplaceTextFrameCharCaption Sheets("Sheet1"), "検索する文字列", "置換する文字列"
End Sub

' ' /// TextFrameのChractersについてCaptionのみ置換し、Formatは変更しない
' ' 引数 Sh　：　シート(Worksheet、Chart）オブジェクトを指定します。
' ' 引数 sWhat　：　検索する文字列を指定します。
' ' 引数 sReplace　：　置換する文字列を指定します。
' ' 引数 ShapeType　：　省略可能です。MsoShapeType（シェイプ）のType（種類）を指定します。
' ' 　　　　　　　　　　この引数を省略した場合の既定値はmsoAutoShape（オートシェイプ）です。
' ' ///
Sub ReplaceTextFrameCharCaption(ByVal Sh As Object, _
　　　　　　　　　　ByVal sWhat As String, ByVal sReplace As String, _
　　　　　　　　　　Optional ByVal ShapeType As MsoShapeType = msoAutoShape)
Dim shp As Shape
Dim sBuf As String
Dim nLen As Long
Dim nPos As Long
　　Select Case TypeName(Sh)
　　Case "Worksheet", "Chart"
　　Case Else:　　MsgBox "引数の型が違います。":　　Exit Sub
　　End Select

　　nLen = Len(sWhat)
　　For Each shp In Sh.Shapes
　　　　If shp.Type = ShapeType Then
　　　　　　With shp.TextFrame
　　　　　　　　Do
　　　　　　　　　　nPos = InStr(nPos + 1, .Characters.Text, sWhat)
　　　　　　　　　　If nPos Then
　　　　　　　　　　　　.Characters(nPos, nLen).Caption = sReplace
　　　　　　　　　　End If
　　　　　　　　Loop While nPos
　　　　　　End With
　　　　End If
　　Next
End Sub
' ' ///

ところで、
> オートシェイプ内のテキストを一括して置換したいと考えております。
この一文の「一括して置換したい」の意味が、一意ではないような気がしてきました。
最近見かけた類似の質問
http://okwave.jp/qa/q8978930.html
の例に倣って、
「複数のオートシェイプに対してテキスト置換を一括で実現したい」
という解釈でお応えしています。
或いは、
「ひとつのオートシェイプに対してテキストに含まる検索文字列を
　すべて他の置換文字列に置換したい」
という意味だった場合は、詳しく、使い方を補足説明して貰えれば、
改めて対応します。
例えば、「選択中のオートシェイプに対して」とか、
「"Rectangle 1"という名前のオートシェイプに対して」とか、
使い方の条件によって対応が大きく異なりますので、、、。

取り急ぎ、以上です。

回答No.2

m_and_dmp

VBA でやるなら、初めに変更前の文字のプロパティ（フォント、色、サイズ）を取得しておいて、文字を変更した後、文字のプロパティを取得したプロパティに設定すると良いと思います。

簡単な方法(VBAではありません）は、セルに記入された文字をオートシェイブに表示する方法です。どこか邪魔にならない場所にオートシェイブに表示する文字を記述しておいて、それをオートシェイブにリンクさせて表示します。セルに記述した文字を変更するとオートシェイブの文字が変更されますが、文字のフォント、色、サイズ、は変わりません。

お礼

回答いただき、ありがとうございます！
でもどのように行うのかイメージできず、申し訳ありません。
今回はVBAで行おうと思います。

回答No.1

real beatin（@realbeatin）

こんにちは。

こんな感じで如何でしょう？
不足があれば、補足欄に書いてみて下さい。

' ' /// 実行マクロ /// ReplaceTextFrameCharCaption の使用例
Sub Re8980222w()
　　ReplaceTextFrameCharCaption Sheets("Sheet1"), "検索する文字列", "置換する文字列"
End Sub

' ' /// TextFrameのChractersについてCaptionのみ置換し、Formatは変更しない
' ' 引数 Sh　：　シート(Worksheet、Chart）オブジェクトを指定します。
' ' 引数 sWhat　：　検索する文字列を指定します。
' ' 引数 sReplace　：　置換する文字列を指定します。
' ' 引数 ShapeType　：　省略可能です。MsoShapeType（シェイプ）のType（種類）を指定します。
' ' 　　　　　　　　　　この引数を省略した場合の初期値はmsoAutoShape（オートシェイプ）です。
' ' ///
Sub ReplaceTextFrameCharCaption(ByVal Sh As Object, _
　　　　　　　　　　ByVal sWhat As String, ByVal sReplace As String, _
　　　　　　　　　　Optional ByVal ShapeType As MsoShapeType = msoAutoShape)
Dim shp As Shape
Dim sBuf As String
Dim nLen As Long
Dim nPos As Long
　　Select Case TypeName(Sh)
　　Case "Worksheet", "Chart"
　　Case Else:　　MsgBox "引数の型が違います":　　Exit Sub
　　End Select

　　nLen = Len(sWhat)
　　For Each shp In Sh.Shapes
　　　　If shp.Type = ShapeType Then
　　　　　　sBuf = shp.TextFrame2.TextRange.Characters.Text
　　　　　　nPos = 0
　　　　　　Do
　　　　　　　　nPos = InStr(nPos + 1, sBuf, sWhat)
　　　　　　　　If nPos Then
　　　　　　　　　　shp.TextFrame.Characters(nPos, nLen).Caption = sReplace
　　　　　　　　End If
　　　　　　Loop While nPos
　　　　End If
　　Next
End Sub

お礼

ありがとうございます！！
無事色が変わらず置換することができました。
いろんなサイトを見たのですがわからず、本当に助かりました。