Excelでセル上の画像を別のセルにコピーするには

質問

いつも楽しく勉強させていただいております。

つぎのような処理をしたいのですが、うまくいきません。

１．セル１の上にある画像をセル２の上にコピーする。
２．コピーした画像をセル２の高さと幅にフィットさせる。

まず、このようなマクロを考えてみました。

Range("A1").CopyPicture
Range("C1").Select
ActiveSheet.Paste
ActiveSheet.Shapes(Selection.Name).LockAspectRatio = msoFalse
ActiveSheet.Shapes(Selection.Name).Top = Range("C1").Top
ActiveSheet.Shapes(Selection.Name).Left = Range("C1").Left
ActiveSheet.Shapes(Selection.Name).Height = Range("C1").Height
ActiveSheet.Shapes(Selection.Name).Width = Range("C1").Width

これですと元の画像がA1のセルより小さい場合、周囲に余白がある形でコピーされてしまいます。
C1にコピーしたら余白はなしでC1の大きさいっぱいに画像を引き延ばしたい（あるいは縮小したい）のです。

そこで次のように変更してみました。
（上のプログラムと一番上の行のみが違います）。

ActiveSheet.Shapes("図 6").Copy
Range("C1").Select
ActiveSheet.Paste
ActiveSheet.Shapes(Selection.Name).LockAspectRatio = msoFalse
ActiveSheet.Shapes(Selection.Name).Top = Range("C1").Top
ActiveSheet.Shapes(Selection.Name).Left = Range("C1").Left
ActiveSheet.Shapes(Selection.Name).Height = Range("C1").Height
ActiveSheet.Shapes(Selection.Name).Width = Range("C1").Width

これもうまくいきません。
A1にある元の"図 6"は動かしたくないのに、勝手にB1の位置に移動してしまいます。
というのは、"図 6"という画像をコピーすると、同じ名前で画像ができちゃうんですね。
コピー元とコピー先の両方の画像に対して位置や高さを設定することになるようです。

ということで、

１．セル１の上にある画像をセル２の上にコピーする。
２．コピーした画像をセル２の高さと幅にフィットさせる。

これを実現させるにはどうしたらいいでしょう。

回答No.3

kybo · ベストアンサー

>１．
そうです。

>２．

こんな感じです。

Sub macro()
Dim C As Shape, N As String
For Each C In ActiveSheet.Shapes
If C.TopLeftCell.Address = "$A$1" Then
N = C.Name
Exit For
End If
Next C
MsgBox N
End Sub

回答No.2

kybo

ボタンもあったのですね。
では、こういうのはどうでしょうか？

ActiveSheet.Shapes("図 6").Select
With Selection.ShapeRange.Duplicate
.LockAspectRatio = msoFalse
.Top = Range("C1").Top
.Left = Range("C1").Left
.Height = Range("C1").Height
.Width = Range("C1").Width
End With

お礼

kyboさん、今回はうまくいきました！

教えてくださいばかりで申し訳ないのですが、

１．With Selection.ShapeRange.Duplicateとすると、
　　コピーした方の図を指すという理解で合っていますか。

２．最初にShapes("図 6")と決め打ちしましたが、
　　A1セルに（左上が）ある図の名前を取得することはできますか。

For Each XXX In ActiveSheet.Shapes
・・・
Next

上記のコードでシート全体の図を全部チェックしてそれらの位置するセルを取得というのは可能かと思うのですが、「A1セルにある図」でピンポイントで探すことは可能でしょうか。

補足

↓の質問１だけ解決です。検索してみたらShapeRange.Duplicateで「オブジェクトを複製し、複製への参照を返します。」とありました。

回答No.1

kybo

Excelのバージョンは2007でしょうか？2010では問題ありません。

以下の様にしてみて下さい。

ActiveSheet.Shapes("図 6").Copy
Range("C1").Select
ActiveSheet.Paste
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).LockAspectRatio = msoFalse
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Top = Range("C1").Top
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Left = Range("C1").Left
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Height = Range("C1").Height
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Width = Range("C1").Width

お礼

kyboさん、回答ありがとうございます。バージョンを書き忘れていましたが、2007です。

教えていただいたコードを試してみました。ところが位置や幅のプロパティの設定がどういうわけか貼り付けた画像でなく同じシートにあるコマンドボタンに働きかけてしまい、コマンドボタンがセルC1の中にすっぽり収まっていました。

ActiveSheet.Shapes.Countは必ずしも直近に追加されたオブジェクトを指すとは限らないのでしょうか・・・。