ExcelマクロVBAサンプル集 | オートシェイプを他ブックの同じ位置に貼り付ける(Shapes,DrawingObjects) | Excelマクロの実用サンプル、エクセル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つずつ処理するのが最も汎用性が高くなります。


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

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

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

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

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

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

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






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

全シートの画面キャプチャを取得する(keybd_event)
写真の取込方法について(Pictures.Insert,Shapes.AddPicture)
写真をサムネイルに変換して取り込む(Shapes.AddPicture)
円グラフの色設定(Chart,SeriesCollection)
棒グラフ・折れ線グラフのサンプルマクロ
人口ピラミッドのグラフをマクロで作成
グラフで特定の横軸の色を変更するマクロ

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

Excelファイルを開かずにシート名をチェック|ExcelマクロVBAサンプル集(3月23日)
数式の参照しているセルを取得する|ExcelマクロVBAサンプル集(3月18日)
CSVの読み込み方法(改の改)|ExcelマクロVBAサンプル集(3月17日)
変数とプロシージャーの命名について|ExcelマクロVBA技術解説(2月12日)
ファイルの一覧取得・削除(File)|Google Apps Script入門(1月24日)
フォルダの一覧取得・作成・削除(Folder)|Google Apps Script入門(1月24日)
フォルダとファイルを扱う(DriveApp)|Google Apps Script入門(1月24日)
スプレッドシートが非常に遅い、高速化するには|Google Apps Script入門(1月17日)
画像のトリミング(PictureFormat,Crop)|ExcelマクロVBAサンプル集(12月27日)
シート保護|Google Apps Script入門(12月24日)

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

1.最終行の取得(End,Rows.Count)|ExcelマクロVBA入門
2.RangeとCellsの使い方|ExcelマクロVBA入門
3.徹底解説(VLOOKUP,MATCH,INDEX,OFFSET)|エクセル関数超技
4.Range以外の指定方法(Cells,Rows,Columns)|ExcelマクロVBA入門
5.セルの参照範囲を可変にする(OFFSET,COUNTA,MATCH)|エクセル関数超技
6.セルのコピー&値の貼り付け(PasteSpecial)|ExcelマクロVBA入門
7.変数とデータ型(Dim)|ExcelマクロVBA入門
8.ひらがな⇔カタカナの変換|エクセル基本操作
9.CSVの読み込み方法|ExcelマクロVBAサンプル集
10.VBAのFindメソッドの使い方には注意が必要です|ExcelマクロVBA技術解説



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

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


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

    ↑ PAGE TOP