概要
テーブルにリストアップしたシェイプ名を
| 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...
最終的には以前作成したの各シートのフッターを一括編集するマクロを使うにしても、あくまでシートごとにしか付与できないのでシートが縦に長い状態だと対応できません。
なので非常に面倒ですがシェイプ追加時に印刷範囲を超えるとシートを追加する必要が出てきます。
正直、このあたりの書式を変える方がはるかに効率改善になるし、属人化問題の初期消火どころかボヤすら発生させない予防策になりますよ。
なのでこの残課題に着手する日を回避することから始めます。
参考
Arr(i).p対象Shape.Copy
.Paste Destination:=.Cells(1, 1)
Copy,Pasteメソッドはあまり使いたくなかったのですが、
真髄さんでさえ使っていたのでしゃーないか。まずは動けばいいしね。
ブック上ではなく画像ファイルを直接呼ぶ方法もありますが、今回の用途はグループ化したシェイプ群を直接いじれることがわかったので未着手。