EXCEL VBAで 図形を中央寄せに関して質問です

EXCELマクロに関して初心者です。
同じブックの中で”シート1”にある画像をを”シート２”に画像サイズが元のまま"C3:R37"に貼り付ける作業がありました。（"C3:R37"　は統合したセルです）下記のマクロ使って貼り付けまではできましたが、中央寄せはできなかったです。
画像サイズそのままで中央寄せることができるんでしょうか？
詳しい方教えてください　よろしくお願いします。
Dim MyShape As shape
Sheets("位置図1").Select
For Each MyShape In ActiveSheet.Shapes
With MyShape
If Not Intersect(Selection, .TopLeftCell) Is Nothing And _
Not Intersect(Selection, .BottomRightCell) Is Nothing Then
.Copy
End If
End With
Next
Sheets("位置図2").Select
Range("C3:R37").Select
ActiveSheet.Paste

For Each MyShape In ActiveSheet.Shapes
MyShapeTop = Range("C3:R37").Top
MyShapeLeft = Range("C3:R37").Left
Next
．．．

No.3 ベストアンサー 回答者： rukaandkaito 回答日時： 2019/06/21 09:00

コピー対象以外にもシェイプ図があるということですね！

でしたら質問者様が記載しているように『For Each』で全てのシェイプ図をループしてIntersectで範囲判定を行っているのもうなずけますが、その場合設定の前に対象のセルを選択していなければいけませんね
ということで修正したコードを記載しておきます
--------------------------------------------------------------------------------
Sub Sample()
　　Dim MyShape1 As Shape
　　Dim MyShape2 As Shape
　　For Each MyShape1 In Sheets("位置図1").Shapes
　　　　With MyShape1
　　　　　　If Not Intersect(Sheets("位置図1").Range("C3:R37"), .TopLeftCell) Is Nothing And _
　　　　　　　 Not Intersect(Sheets("位置図1").Range("C3:R37"), .BottomRightCell) Is Nothing Then
　　　　　　　　.Copy
　　　　　　　　Exit For
　　　　　　End If
　　　　End With
　　Next
　　Sheets("位置図2").PasteSpecial
　　For Each MyShape2 In Sheets("位置図2").Shapes
　　　　MyShape2.Top = MyShape1.Top
　　　　MyShape2.Left = MyShape1.Left
　　Next
End Sub
--------------------------------------------------------------------------------
一応セル選択せずにコピペする仕様にしています。
前提条件として位置図２のシートには最初画像が何もないということで、もし複数の画像がある場合には対象の座標に全て書き換わってしまいますのでご注意ください

この回答へのお礼

お礼遅れまして申し訳ございません。rukaandkaito様の回答参考に目的は達成しました。ありがとうございました。今後ともよろしくお願いいたします。

お礼日時：2019/06/24 16:35

No.4 回答者： WindFaller 回答日時： 2019/06/22 02:27

いまさら、お聞きしたいことがあって書いているので、無視されてもしょうがないかなって思うのですが、少し分からない部分があります。

>If Not Intersect(Selection, .TopLeftCell) Is Nothing
なぜ、セルをアクティベートしているのでしょうか?画像を選択すれば、それに決まっているのだから、検索などしなくてよいと思うのです。つまり、Selection だけで済みます。

あえて必要なら、
If TypeName(Selection) <> "Picture" Then
　　Exit Sub
End If
で、画像以外は除外してもよいでしょう。

>"C3:R37" は統合したセルです
統合とは結合のことだろうと思いましたが、図形を中央寄せするというなら、画像は、C3:R37よりも小さいということだと思います。

貼り付けた画像を、MyPicture としますと、
''d1, d2 は、diffrence, その差です。
With MyPicture
　　w = Range("C3:R37").Width 'セルの幅
　　d1 = (w - .Width) / 2 'セルの範疇の幅から、画像の幅を引いて、残りを2で割ります。
　　h = Range("C3:R37").Height 'シート上の範囲の高さ
　　d2 = (h -.Height) / 2
　　.Left = .Left + d1 '右にずらす
　　.Top = .Top + d2 '下にずらす
　End With

ただ、これは、貼り付け部分のサイズよりも画像のほうが小さいことが無難です。逆に大きいものは、うまく行かない可能性があります。

この回答へのお礼

No.3 様の回答参考に目的は達成しました。 WindFaller様の回答今後参考にさせていただきます。ありがとうございました。

お礼日時：2019/06/24 16:31

No.2 回答者： rukaandkaito 回答日時： 2019/06/20 18:34

とまりましたと言うのは上手く動かなかったということでしょうか？

ちなみにですが、双方画像は一つだけですよね？
現在は『For Each』をつかってシェイプを検索していますが、１つ固定という事であればShape(1)でも対応できると思います。
なので、簡素化したコードをもう一度記載しますので試してみて下さい
--------------------------------------------------------------------------------
　Sheets("位置図1").Shapes(1).Copy
　Sheets("位置図2").Paste
　Sheets("位置図2").Shapes(1).Top = Sheets("位置図1").Shapes(1).Top
　Sheets("位置図2").Shapes(1).Left = Sheets("位置図1").Shapes(1).Left
--------------------------------------------------------------------------------
至ってシンプルですが位置図１のシェイプを位置図２にコピー後TopとLeftの座標を設定しているだけです

この回答へのお礼

回答ありがとうございました。
Sheets("位置図1").Shapes(1).Copy
　Sheets("位置図2").Paste　
使うと目的の画像ではなく別の四角形を選択＆貼り付けになってしまい、目的は達成できなかったです。

お礼日時：2019/06/20 19:04

No.1 回答者： rukaandkaito 回答日時： 2019/06/20 17:14

記載の内容だと位置図２のシートのシェイプの位置がRange("C3:R37")になっていますので恐らく左上に張り付いていると思います。

なので例えば位置図１と位置図２のMyShapeをそれぞれ別に用意して同じ座標を指定しては如何でしょうか
--------------------------------------------------------------------------------
　Dim MyShape1 As shape
　Dim MyShape2 As shape
　Sheets("位置図1").Select
　For Each MyShape1 In ActiveSheet.Shapes
　　With MyShape1
　　　If Not Intersect(Selection, .TopLeftCell) Is Nothing And _
　　　　Not Intersect(Selection, .BottomRightCell) Is Nothing Then
　　　　.Copy
　　　End If
　　End With
　Next
　Sheets("位置図2").Select
　Range("C3:R37").Select
　ActiveSheet.Paste
　For Each MyShape2 In ActiveSheet.Shapes
　　MyShape2.Top = MyShape1.Top
　　MyShape2.Left = MyShape1.Left
　Next
--------------------------------------------------------------------------------
こちら未検証ですので試してダメだったらまたお知らせください

この回答へのお礼

回答ありがとうございました。MyShape2.Top = MyShape1.Top でマクロとまりました。

お礼日時：2019/06/20 17:47