Excelvba 図形のコピー

質問

Excelvba 2010のVBAについてご教授願います。

Sheet1にある楕円の図形をSheet2の結合セルの個所にコピーしたいのですが、
コピーできません（貼付できていないといった方が良いのかも）。
但し、コピー先の結合セルには文字が入っており（「有」という文字）、
この文字はそのまま残した方法で楕円の図のみ文字の上に上書きというか
文字にかぶせたいのです。

コードは以下の様に記述しました。

WorkSheets("Sheet2").Activate
Worksheets("Sheet1").Shapes("楕円").Select
Selection.Copy
ActiveSheets.Range("EE120").MergeArea.Select
ActiveSheet.Paste

回答No.1

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

こんにちは。

普通にコピーして貼り付けるだけだったら、こんな感じです。

Sub Re8912718()
　　Worksheets("Sheet1").Shapes("楕円").Copy
　　Worksheets("Sheet2").Range("EE120").PasteSpecial
End Sub

もし、サイズをアクティブセルに合わせて変更したいという場合は、

　　With Worksheets("Sheet2")
　　　　With .Shapes(.Shapes.Count)
　　　　　　.Height = ActiveCell.Height
　　　　　　.Width = ActiveCell.Width
　　　　End With
　　End With

のような記述を上記に続けます。

コピーしたい楕円図形のオブジェクト名は"楕円"で間違いないでしょうか？
もし違っていれば当然エラーになるので気が付くとは思いますが、
もし、そこら辺でお困りの場合は、以下。
Sheet1にある楕円図形の名前をＶＢＥ上のイミディエイトウィンドウに列挙します。

Sub ChkShapeName()
Dim o As Shape
　　For Each o In Worksheets("Sheet1").Shapes
　　　　If o.AutoShapeType = msoShapeOval Then
　　　　　　Debug.Print o.Name
　　　　End If
　　Next
End Sub

以上です。

お礼

お礼が遅くなり、誠に申し訳ございませんでした。
おかげを持ちまして、無事に出来ました。
本当にありがとうございました。

補足

下記の個所で、以下の様なメッセージが出力されます。
なぜなんでしょう？

実行時エラー'438'
オブジェクトは、このプロパティまたはメソッドをサポートしていません。

Worksheets("Sheet2").Range("EE120").PasteSpecial

回答No.6

real beatin（@realbeatin）

＃１,２,４,５です。

＃５に加えてもう１例挙げておきますね。
違いを比べると一長一短ですが、
お好きな方、解り易いと感じる方を選んでください。
こちらは、登録したマクロについて何も処理しなくても踏襲されます。
その代わり、貼付け先のシート、セル範囲を選択してからでないと
貼り付け出来ません。

Sub Re8912718a()
　　Worksheets("Sheet1").Shapes("楕円").Copy
　　With Worksheets("Sheet2")
　　　　.Select
　　　　.Range("EE120").Select
　　　　.Paste
　　End With
　　ActiveCell.Activate
End Sub

回答No.5

real beatin（@realbeatin）

＃１,２,４です。＃４補足欄への返答。

実質２ヶ所追加になります。
（１）元の図形に登録されたマクロ名を
　　　一旦、変数に格納しておいて、
（２）新しい図形に対して
　　　.OnActionプロパティにマクロ名を登録します。

Sub Re8912718追加()
Dim MacroName As String
　　With Worksheets("Sheet1").Shapes("楕円")
　　　　.Copy
　　　　MacroName = .OnAction　'　（１）
　　End With
　　With Worksheets("Sheet2")
　　　　.Range("EE120").PasteSpecial
　　　　.Shapes(.Shapes.Count).OnAction = MacroName　'　（２）
　　End With
End Sub

以上です。

お礼

返事が遅くなり、誠に申し訳ございませんでした。
ご教授通り行いましたら、できました。
感謝！感謝！です。
ありがとうございました。

回答No.4

real beatin（@realbeatin）

＃１-２です。
念の為、補足しておきますが、
こちらの環境、Win 7 x64, Excel2010 x64、では、
コピーした図形を、
＃１のrange.PasteSpecial メソッドで、
問題なく貼り付けが出来ることを相当な回数確かめていますし、
.Copy と .PasteSpecial の間に、
Application.CutCopyMode = False 等の記述を挟むと、
ご指摘のエラーと同じ状況が再現できることも確認しています。
念の為。

補足

お返事が遅れて誠に申し訳ございません。
小生のミスである事がわかりました。
大変失礼を致しました。

関連して再度質問をしたいのですが、
コピー元の図にマクロが登録されている場合は、
マクロ部分はコピーされないのでしょうか？
（実際に試した結果、図はコピーされるのは確認しましたが、
　マクロ部分がコピーされない現象は確認したつもりです。）。
コピーされないとすると、同じマクロを自動的にコピー後の図に
登録する事などはできないのでしょうね？

回答No.3

imogasi

テスト例として
SheetIに楕円を１つ貼り付け。
Sheet2のC11:D11のセルを結合（中央配置）して、セルの値を入れた（すでに値があれば何もしない）。
標準モジュールに
Sub test01()
Worksheets("Sheet1").Shapes(1).Copy
Worksheets("Sheet2").Activate
ActiveSheet.Paste
Worksheets("Sheet2").Shapes(1).Top = Range("c10").Top
Worksheets("Sheet2").Shapes(1).Left = Range("c10").Left - 10
End Sub
上記で質問者の状況（ニーズ）にこたえられない場合は、ご容赦を。
Range("c10").Left - 10のー10の±と数字を変えれば調節できます。Top位置も同じことができる。
貼り付けた図形の大きさには、貼り付け後、セルの高さや幅の変動に連動する設定もあるので
ご参考まで。
質問者の使っているCopyやPasteはシートに対して行えるもので、セルやMergeAreaを指定してはできない
のではないかな。そういうメトッドがVBAでは作られてないといえばよいのかな。

回答No.2

real beatin（@realbeatin）

＃１です。補足欄への返答です。

> 下記の個所で、以下の様なメッセージが出力されます。
> なぜなんでしょう？
>
> 実行時エラー'438'
> オブジェクトは、このプロパティまたはメソッドをサポートしていません。
>
> Worksheets("Sheet2").Range("EE120").PasteSpecial

　　Worksheets("Sheet1").Shapes("楕円").Copy
の行ではエラーがないようですから、
図形のコピーまでは正しく出来ていることになります。
図形をコピーしたデータがクリップボードに確保され、
貼り付けを待機している状態になります。
　　Worksheets("Sheet2").Range("EE120").PasteSpecial
この行でご指摘の様なエラーで発生する原因として考えられるのは、
図形をコピーした記述の後に何かしら記述があって、
クリップボードのデータをキャンセルしている場合が考えられます。
もしも他に原因があるとしてもエラーが発生する過程は同じです。
また、こちらで想定できない原因があるとすれば、
何か特別なことをしているのに、こちらには伝わっていない、
ということですので、何か特別なことはないか、
探ってみてください。

図形をコピーした記述の後に何かしら記述がある場合、
まず、その記述を一旦消した上で実行して結果を確かめてから、
書き換えが難しいようでしたら、記述を見せてください。

取り急ぎ、以上です。