[[20251112103235]]　『特定の図形のみ選んで別の図形に変更』（ＫＯＫＯ）　ページの最後に飛ぶ

『特定の図形のみ選んで別の図形に変更』（ＫＯＫＯ）

お世話になっております。

図形の変更について質問です。
複数のシートに図形をつかって説明文を作成しました。
図形の種類が複数あり、それぞれテキストで文字をいれてあります。
同じ種類の図形で色やテキストのみ異なっている図形もあります。
その図形を変更する必要がでてきましたが、数が多く新しく作成した図形を配置するのが大変です。

ＳＨＥＥＴ１のＡ1に元の図形をおき、Ａ2に新しい図形をおき、Ａ1の図形をＡ2の図形にマクロで変更する
などということは可能でしょうか
可能であればご教示願います。

図形の変更マクロはネットでみつけたのですが、自分の場合はテキストが入力されているので無理でした。

＜使用 Excel：Excel2021、使用 OS：Windows11 ＞

＞Ａ1の図形をＡ2の図形に
コピーすればいいのでは。
＞その図形を変更する必要がでてきました
＞マクロで変更する
なにを変更するのですか。
（わからん） 2025/11/12(水) 11:42:43

 「A1に元の図形をおき、A2に新しい図形をおき・・・」とかしないで、
 シート上の図形を直接変更するサンプル（楕円を四角にする例）。
 図形に入力されているテキストもそのまま。

 Sub test()
   Dim shp As Shape
   For Each shp In ActiveSheet.Shapes
     If shp.AutoShapeType = msoShapeOval Then
       shp.AutoShapeType = msoShapeRectangle
     End If
   Next
 End Sub

 なお、AutoShapeのタイプは以下で確認してね。
https://learn.microsoft.com/ja-jp/office/vba/api/office.msoautoshapetype

（408納車） 2025/11/12(水) 11:47:06

回答ありがとうございます
楕円が四角に変換は成功しました。
ですが、このファイルで使用している図形は
楕円で色が赤テキストが”あ”
楕円で色が青テキストが”い”
などが混在しているので
全ての楕円が四角になってほしくないのです
なのでA1に元の図形をおき、A2に新しい図形をおき...の方法ができないものかと思った次第です
可能でしょうか
（ＫＯＫＯ） 2025/11/12(水) 12:39:00

 A1においた図形と、他のシートにある図形が同じかどうか判定できないといけないですね

 図形のプロパティはいろいろ有りすぎて、全部のプロパティを比較するコードを書くのは大変です
 全てのプロパティを比較して同一性を判定するのは「技術的には可能だけど現実的ではない」です

 シェープの種類、塗りの色、線の色、線の種類etc 比較するプロパティを
 ある程度現実的な数に絞り込めるならなんとかなると思います
（´・ω・`） 2025/11/12(水) 13:31:05

回答ありがとうございます
＞「技術的には可能だけど現実的ではない」です
自分には難易度がかなり高いと思われます
とりあえず手作業で頑張ります
お世話になりました

（ＫＯＫＯ） 2025/11/12(水) 14:50:54

 既に回答があったとおりかと思います。

 以下、参考です。
 「オブジェクトの選択と表示」で複数の対象図形を選択できます。
 そうすると、「図形の書式」メニューがリボンに選択肢として現れます。
 このなかで
  ・図形の種類
  ・塗りつぶし色
  ・枠線
  ・文字色
 などは一括して変換できますね。
（テキスト編集はできないようですけど。）

（xyz） 2025/11/12(水) 15:30:32

 難易度はそれほど高くないと思います。面倒なだけ

 具体的には、以下のような関数を作れれば良くて、
 比較するプロパティの数だけ、IF文が必要で、、、
 shapeのプロパティ全てを並べるのは現実的に困難だけど、
 このプロパティだけを比較すれば間に合うよ、というのが利用する側で決まって入れば、
 そんなに難しくないという

 Function isShpEqual(shp1 As Shape, shp2 As Shape) As Boolean
   isShpEqual = False
   If shp1.Type <> shp2.Type Then Exit Function
   If shp1.Fill.ForeColor <> shp2.Fill.ForeColor Then Exit Function
   If shp1.Fill.BackColor <> shp2.Fill.BackColor Then Exit Function
   If shp1.Line.ForeColor <> shp2.Line.ForeColor Then Exit Function
   If shp1.Line.DashStyle <> shp2.Line.DashStyle Then Exit Function
   If shp1.Line.Weight <> shp2.Line.Weight Then Exit Function
   isShpEqual = True
 End Function
（´・ω・`） 2025/11/12(水) 17:52:47

 こんな感じで
 ShpMoto と同じ図形を ShpNew に置き換えます
 対象のシートは　Sheet1以外の全シートです。
 ShpMoto と ShpNew は名前で指定する方がよさそう

 Sub ReplaceShape()
    Dim ShpMoto As Shape, ShpNew As Shape
    Dim ws As Worksheet, shp As Shape

    Set ShpMoto = Worksheets("Sheet1").Shapes(1)
    Set ShpNew = Worksheets("Sheet1").Shapes(2)

    For Each ws In Worksheets
        If ws.Name <> "Sheet1" Then
           For Each shp In ws.Shapes
               If isShpEqual(ShpMoto, shp) Then
                  ShpNew.Copy
                  Application.Goto shp.TopLeftCell
                  ws.Paste
                  With Worksheets(2).Shapes(Worksheets(2).Shapes.Count)
                     .Left = shp.Left
                     .Top = shp.Top
                  End With
                  shp.Delete
               End If
           Next
        End If
    Next
 End Sub

 Function isShpEqual(shp1 As Shape, shp2 As Shape) As Boolean
   isShpEqual = False
   If shp1.Type <> shp2.Type Then Exit Function
   If shp1.Fill.ForeColor <> shp2.Fill.ForeColor Then Exit Function
   If shp1.Fill.BackColor <> shp2.Fill.BackColor Then Exit Function
   If shp1.Line.ForeColor <> shp2.Line.ForeColor Then Exit Function
   If shp1.Line.DashStyle <> shp2.Line.DashStyle Then Exit Function
   If shp1.Line.Weight <> shp2.Line.Weight Then Exit Function
   isShpEqual = True
 End Function
（´・ω・`） 2025/11/13(木) 10:28:26

コメント返信：

[ 一覧(最新更新順) ]

[[20251112103235]] 『特定の図形のみ選んで別の図形に変更』（ＫＯＫＯ） ページの最後に飛ぶ

[[20251112103235]]　『特定の図形のみ選んで別の図形に変更』（ＫＯＫＯ）　ページの最後に飛ぶ