オートシェイプを他ブックの同じ位置に貼り付ける（Shapes,DrawingObjects）
コメントでリクエストを頂きました。
「１つのシートにバラバラにあるオートシェープを一度に選択して、コピーし、
ほかのブックのあるシートの同じ位置にペーストしたい」
というもの。
これには色々な問題が含まれています。
１．マクロの記録に関する問題
２．同じ位置とは・・・行高、列幅が違う場合は
まず、
１．マクロの記録に関する問題
Excel2007では、オートシェイプのSelectが正しく記録されません。
私の環境だけではないですよね、
２台のPCでダメでしたので。
２．同じ位置とは・・・行高、列幅が違う場合は
これは、行列見出しからの位置を同じとするか、
開始セル位置を同じにするかです。
以下では、いろいろな方法を紹介していますので、
いずれか、お好きな方法を選択して下さい。
Book1.xlsのSheet1の図形を全て、Book2.xlsのSheet2へコピーします。
まずは、マクロの記録に近い形でやってみましょう。
Sub ShapeCopy1()
With
Workbooks("Book1.xls")
.Activate
.Worksheets("Sheet1").Select
.Worksheets("Sheet1").Shapes.SelectAll
Selection.Copy
End
With
With Workbooks("Book2.xls")
.Activate
With
.Worksheets("Sheet2")
.Select
.Range("A1").Select
.Paste
End
With
End With
End Sub
Shapes.SelectAll
これで、そのシートの全図形を選択できます。
Withを多用していて、少しわかりずらかったかもしれません。
まあ、普通にコピーし、普通に貼り付けしているだけです。
ただし、これでは、違う位置に貼り付けられます。
上のマクロをもっと簡単に記述すると、以下になります。
Sub
ShapeCopy2()
Workbooks("Book1.xls").Worksheets("Sheet1").DrawingObjects.Copy
Workbooks("Book2.xls").Worksheets("Sheet2").Paste
End
Sub
注意点は、
DrawingObjects.Copy
ここですね。
Shapesでは、.Copyが使えません。
Shapesは、DrawingObjectsなのです。
最初のマクロ同様、違う位置に貼り付けられますね。
そこで、貼り付け位置を、Book1.xlsのSheet1より取得します。
Sub ShapeCopy3()
Dim myShape As Variant
Dim rowMin As Long, colMin
As Long
rowMin = Rows.Count
colMin = Columns.Count
For Each
myShape In Workbooks("Book1.xls").Worksheets("Sheet1").Shapes
If rowMin
> myShape.TopLeftCell.Row Then
rowMin =
myShape.TopLeftCell.Row
End If
If colMin >
myShape.TopLeftCell.Column Then
colMin =
myShape.TopLeftCell.Column
End
If
Next
Workbooks("Book1.xls").Worksheets("Sheet1").DrawingObjects.Copy
With
Workbooks("Book2.xls")
.Activate
With
.Worksheets("Sheet2")
.Select
.Cells(rowMin,
colMin).Select
.Paste
End With
End With
End
Sub
全ての図形について、左上のセルを取得し、
最も左と、最も上の位置を取得します。
そして、その位置に一括で張り付けています。
これで、ほぼ良さそうですが、行高、列幅が違う場合は、
見た目の位置は、違った位置に張り付いてしまいます。
では、行列の見出しからの位置を同じにする為に、
コピー後に、位置をずらしてみましょう。
Sub ShapeCopy4()
Dim obj As Object
With
Workbooks("Book1.xls")
.Activate
.Worksheets("Sheet1").Select
.Worksheets("Sheet1").Shapes.SelectAll
Selection.Ungroup
Set
obj = Selection.Group
obj.Copy
End With
With
Workbooks("Book2.xls")
.Activate
With
.Worksheets("Sheet2")
.Select
.Cells(1,
1).Select
.Paste
Selection.Top = obj.Top
Selection.Left = obj.Left
Selection.Ungroup
End
With
End With
obj.Ungroup
End Sub
一つずつやるのは面倒なので、一旦グループ化しています。
そして、グループごとコピー貼り付け後に、位置をずらしています。
元々、いくつかのグループを作成している場合は都合が悪いです。
そこで、一つずつコピーしてみましょう。
当初のリクエストでは一括でとありましたが、
別にコピー事態が一括である必要はないでしょう。
Sub ShapeCopy5()
Dim myShape As
Variant
Workbooks("Book2.xls").Activate
Worksheets("Sheet2").Select
For
Each myShape In
Workbooks("Book1.xls").Worksheets("Sheet1").Shapes
myShape.Copy
ActiveSheet.Paste
Selection.Top
= myShape.Top
Selection.Left = myShape.Left
Next
End
Sub
正直なところ、これが一番良いと思いますね。
私が、単純に作成するとしたら、このようなマクロになると思います。
これなら、オートシェイプを取捨選択できますし、
３番目のマクロのように、
myShape.TopLeftCell
を使用すれば、同じセル位置にも貼り付けが可能です。
処理スピード等の問題がなければ、
オブシェクトは、For Eachで１つずつ処理するのが最も汎用性が高くなります。
いかがでしたでしょうか。
なお、エラー処理は入れていませんので、図形が無い場合等の対処は適時入れて下さい。
また、図形の選択状態を解除していませんので、セルの選択等も適時入れて下さい。
ぱっと読むと簡単そうに見える処理も、いろいろな条件を考えると、結構難しい面があります。
質問者様は、ネットで良いコードが見つからなかったとありましたが、
上記の全てのマクロを理解できるように説明しているサイトは無いと思います。
このようなリクエストは大歓迎です。
同じテーマ「マクロVBAサンプル集」の記事
全シートの画面キャプチャを取得する（keybd_event）
新着記事NEW ・・・新着記事一覧を見る
TRIMRANGE関数（セル範囲をトリム：端の空白セルを除外）｜エクセル入門(2024-08-30)
正規表現関数（REGEXTEST,REGEXREPLACE,REGEXEXTRACT）｜エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない｜エクセル雑感(2024-04-11)
ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.繰り返し処理（For Next)｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.セルのクリア（Clear,ClearContents）｜VBA入門
8.メッセージボックス(MsgBox関数)｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.ブック・シートの選択（Select,Activate）｜VBA入門
- ホーム
- マクロVBA応用編
- マクロVBAサンプル集
- オートシェイプを他ブックの同じ位置に貼り付ける（Shapes,DrawingObjects）
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。