VBAサンプル集
オートシェイプを他ブックの同じ位置に貼り付ける(Shapes,DrawingObjects)

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
最終更新日:2013-06-04

オートシェイプを他ブックの同じ位置に貼り付ける(Shapes,DrawingObjects)


コメントでリクエストを頂きました。

「1つのシートにバラバラにあるオートシェープを一度に選択して、コピーし、
ほかのブックのあるシートの同じ位置にペーストしたい」

というもの。

これには色々な問題が含まれています。

1.マクロの記録に関する問題

2.同じ位置とは・・・行高、列幅が違う場合は

まず、

1.マクロの記録に関する問題

Excel2007では、オートシェイプのSelectが正しく記録されません。

私の環境だけではないですよね、

2台のPCでダメでしたので。

2.同じ位置とは・・・行高、列幅が違う場合は

これは、行列見出しからの位置を同じとするか、

開始セル位置を同じにするかです。

以下では、いろいろな方法を紹介していますので、

いずれか、お好きな方法を選択して下さい。



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

正直なところ、これが一番良いと思いますね。

私が、単純に作成するとしたら、このようなマクロになると思います。

これなら、オートシェイプを取捨選択できますし、

3番目のマクロのように、

myShape.TopLeftCell

を使用すれば、同じセル位置にも貼り付けが可能です。

処理スピード等の問題がなければ、

オブシェクトは、For Eachで1つずつ処理するのが最も汎用性が高くなります。


いかがでしたでしょうか。

なお、エラー処理は入れていませんので、図形が無い場合等の対処は適時入れて下さい。

また、図形の選択状態を解除していませんので、セルの選択等も適時入れて下さい。

ぱっと読むと簡単そうに見える処理も、いろいろな条件を考えると、結構難しい面があります。

質問者様は、ネットで良いコードが見つからなかったとありましたが、

上記の全てのマクロを理解できるように説明しているサイトは無いと思います。

このようなリクエストは大歓迎です。





同じテーマ「マクロVBAサンプル集」の記事

コメントの位置移動と自動サイズ調整とフォント設定
図をセル内に強制的に収める(Shape)
図を確認しながら消していく(Shape)
オートシェイプを他ブックの同じ位置に貼り付ける(Shapes,DrawingObjects)
全シートの画面キャプチャを取得する(keybd_event)
写真の取込方法について(Pictures.Insert,Shapes.AddPicture)
写真をサムネイルに変換して取り込む(Shapes.AddPicture)
円グラフの色設定(Chart,SeriesCollection)
棒グラフ・折れ線グラフのサンプルマクロ
人口ピラミッドのグラフをマクロで作成
グラフで特定の横軸の色を変更し基準線を引くマクロ


新着記事NEW ・・・新着記事一覧を見る

列全体を指定する時のRangeとColumnsの違い|ツイッター出題回答 (2023-09-24)
シートのActiveXチェックボックスの指定方法|ツイッター出題回答 (2023-09-24)
ByRef引数の型が一致しません。|ツイッター出題回答 (2023-09-22)
シートコピー後のアクティブシートは何か|ツイッター出題回答 (2023-09-19)
Excel関数の引数を省略した場合について|ツイッター出題回答 (2023-09-14)
セル個数を返すRange.CountLargeプロパティとは|VBA技術解説(2023-09-08)
記号を繰り返してグラフ作成(10単位で折り返す)|ツイッター出題回答 (2023-08-28)
シートを削除:不定数のシート名に対応|VBAサンプル集(2023-08-24)
ランクによりボイントを付ける(同順位はポイントを分割)|ツイッター出題回答 (2023-08-22)
OneDrive使用時のThisWorkbook.Pathの扱い方|VBA技術解説(2023-07-26)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.繰り返し処理(For Next)|VBA入門
4.変数宣言のDimとデータ型|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.マクロとは?VBAとは?VBAでできること|VBA入門
7.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
8.並べ替え(Sort)|VBA入門
9.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
10.条件分岐(IF)|VBA入門




このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ