概要

テーブルにリストアップしたシェイプ名を

Shapeまとめwb名	Shapeまとめws名	対象Shape名	貼り付け先wb名	貼り付け先ws名
画像まとめブック.xlsx	Sh1	Gr2	貼り付け先ブック.xlsx	Sheet2
画像まとめブック.xlsx	Sh1	Gr1	貼り付け先ブック.xlsx	Sheet1
画像まとめブック.xlsx	Sh2	Gr2	貼り付け先ブック.xlsx	Sheet1

画像とかオートシェイプをまとめたブックから探してきて
（あらかじめシェイプやグループに名前を付けておく必要あり）

対象ブックにグループごと転記する

というもの

注意点

同名シェイプについて

ExcelもPowerPointも同じ名前のシェイプが存在しても良いことになっているので、転記元も転記先も同じ名前のシェイプがあると思ってたんと違う動きになります。

転記先は基本的に新規作成を前提で作っているので無視するとして、転記元ブックのシェイプ名管理は量が増えてくると別で必要かも。

縦に追加して貼り付けていく仕様です

縦に連続で貼り付けていくようにしてあるので、所定の位置にしたいとか、既存のシェイプの間に入れたいとかは別途調整必要です。

コード

Option Explicit

Const wb名画像まとめブック = "画像まとめブック.xlsx"
Const wb名貼り付け先ブック = "貼り付け先ブック.xlsx"
Const tblName = "テーブル1"
Const PosLeft = 100
Const Pos縦隙間 = 10

Private Enum c
  cShpまとめwb名 = 1
  cShpまとめws名
  c対象Shape名
  c貼り付け先wb名
  c貼り付け先ws名
End Enum

Private Type Property_
  pShpまとめwb名 As String
  pShpまとめwb As Workbook
  
  pShpまとめws名 As String
  pShpまとめws As Worksheet
  
  p対象Shape名 As String
  p対象Shape As Object
  
  p貼り付け先wb名 As String
  p貼り付け先wb As Workbook
  
  p貼り付け先ws名 As String
  p貼り付け先ws As Worksheet
End Type
Dim Arr() As Property_

Sub 別ブックから画像を持ってくる()
  Application.ScreenUpdating = False
  Call Set下ごしらえ
  
  Dim i As Long
  Dim ws As Worksheet
  Dim PosTop As Double
  For i = 1 To UBound(Arr)
    Set ws = Arr(i).p貼り付け先ws
    With ws
      '貼り付け
      PosTop = シート内の際下端シェイプの下端座標(ws) + Pos縦隙間 '貼り付け前に既存のシェイプ位置を取得しておく
      Arr(i).p対象Shape.Copy
      .Paste Destination:=.Cells(1, 1)
      
      '貼り付けた図の位置決め
      With .Shapes(Arr(i).p対象Shape.Name)
        .Left = PosLeft
        .Top = PosTop
      End With
      
    End With
  Next
  Application.ScreenUpdating = True
End Sub

Private Sub Set下ごしらえ()
  Dim myTable As ListObject: Set myTable = Range(tblName).ListObject
  Dim i, cnt
  Dim tblDB As Range: Set tblDB = myTable.DataBodyRange
  
  cnt = tblDB.Rows.Count
  ReDim Arr(cnt)
  
  For i = 1 To cnt
    With Arr(i)
      .pShpまとめwb名 = tblDB(i, c.cShpまとめwb名)
      .pShpまとめwb名 = tblDB(i, c.cShpまとめwb名)
      .pShpまとめws名 = tblDB(i, c.cShpまとめws名)
      .p対象Shape名 = tblDB(i, c.c対象Shape名)
      .p貼り付け先wb名 = tblDB(i, c.c貼り付け先wb名)
      .p貼り付け先ws名 = tblDB(i, c.c貼り付け先ws名)
      
      Set .pShpまとめwb = Workbooks(.pShpまとめwb名)
      Set .pShpまとめws = .pShpまとめwb.Sheets(.pShpまとめws名)
      Set .p対象Shape = .pShpまとめws.Shapes(.p対象Shape名)
      Set .p貼り付け先wb = Workbooks(.p貼り付け先wb名)
      Set .p貼り付け先ws = .p貼り付け先wb.Sheets(.p貼り付け先ws名)
    End With
  Next
  
End Sub

Private Function シート内の際下端シェイプの下端座標(ws As Worksheet) As Double
  Dim shp As Shape
  Dim shp暫定 As Shape
  
  If Is指定wsにShapeが存在する(ws) Then
    Set shp暫定 = ws.Shapes(1) '仮で1番目のシェイプを指定
    For Each shp In ws.Shapes
      With shp
        If .Top > shp暫定.Top Then
          Set shp暫定 = shp
        End If
      End With
    Next
    シート内の際下端シェイプの下端座標 = shp暫定.Top + shp暫定.Height
  Else
    シート内の際下端シェイプの下端座標 = 0
  End If
  
End Function

Private Function Is指定wsにShapeが存在する(ws As Worksheet) As Boolean
  If ws.Shapes.Count = 0 Then
    Is指定wsにShapeが存在する = False
  Else
    Is指定wsにShapeが存在する = True
  End If
End Function

残課題

シェイプ追加時に印刷範囲を超えるとシートを追加する機能

Excelを印刷物に使うのは嫌いなのですが、社内の文書フォーマットがExcelになっており、かつフッターのページ番号がただの連番ではなく、親ページ番号＋枝番、表紙と目次にはページ番号はつけないという面倒な書式になっているので下記リンクのような瞬殺技が使えませんorz...

最終的には以前作成したの各シートのフッターを一括編集するマクロを使うにしても、あくまでシートごとにしか付与できないのでシートが縦に長い状態だと対応できません。

なので非常に面倒ですがシェイプ追加時に印刷範囲を超えるとシートを追加する必要が出てきます。

正直、このあたりの書式を変える方がはるかに効率改善になるし、属人化問題の初期消火どころかボヤすら発生させない予防策になりますよ。

なのでこの残課題に着手する日を回避することから始めます。

参考

Sub_別ブックから画像を持ってくる()

Arr(i).p対象Shape.Copy
.Paste Destination:=.Cells(1, 1)

Copy,Pasteメソッドはあまり使いたくなかったのですが、

真髄さんでさえ使っていたのでしゃーないか。まずは動けばいいしね。

ブック上ではなく画像ファイルを直接呼ぶ方法もありますが、今回の用途はグループ化したシェイプ群を直接いじれることがわかったので未着手。