エクセルVBA 図のコピー&ペーストの方法

質問

いつもお世話になっております。

VBAを学習中の者です。

今回は図のコピー＆ペーストについて教えてください。

（作成中の表：Excel2010を使用）
(1)Sheet1：帳票一覧
　A列：NO　B列：氏名　C列：写真　D列：プロフィール　　のような表を行毎に作成しています。

(2)Sheet2：個別帳票雛形
　マクロの実行により、雛形シートをコピーして、配列に格納したデータをコピーしたシートの指定箇所に転記

簡単に説明するとこのような作業を行いたいと考えています。

現在写真以外の転記については問題無く処理が行えました。

（仕様）
1.写真には01,02,03,04・・・・・と名称を付けております。
2.転記先シートのB4～C12セルを結合して写真の貼付エリアとしています。
3.転記時に画像データのサイズを自動調整（又は貼付エリアに見栄えよく貼れるように数値を指定）
4.貼付エリアの中央にくるように配置

以上を行いたいと思っております。

どうぞよろしくお願いします。
、

回答No.1

mitarashi

>1.写真には01,02,03,04・・・・・と名称を付けております。

この部分が明確で無いので回答が付かないのでしょう。
Pictureオブジェクトの名前を付け替えられる才覚がある人なら、写真の転記もご自分でできると考えますので。

写真がSheet1のC列にあるとして、どうやって名前を付けてあるのでしょうか？

仕様の2～4だけやってみました。ご参考まで。
コードのmypicをどうやって特定するのか、仕様1が不明確です。
Sub test()
Dim mypic As Picture
Set mypic = Sheets("Sheet1").Pictures(1)
copyToMergeCell Sheets("Sheet2").Range("B4"), mypic
End Sub

Sub copyToMergeCell(targetcell As Range, targetPic As Picture)
Dim sh As Worksheet, currentSh As Worksheet
Dim targetArea As Range
Dim newPic As Picture
Dim xOffset As Double, yOffset As Double
Dim xScale As Double, yScale As Double, myScale As Double
Dim mergeHeight As Double, mergeWidth As Double
Dim i As Long, j As Long

Const xSpan As Double = 5
Const ySpan As Double = 5

Application.ScreenUpdating = False
Set currentSh = ActiveSheet
Set sh = targetcell.Parent
Set targetArea = targetcell.MergeArea
targetPic.Copy
sh.Activate
targetcell.Select
sh.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
Set newPic = Selection
With targetArea
For i = 1 To .Rows.Count
mergeHeight = mergeHeight + .Rows(i).Height
Next i
For j = 1 To .Columns.Count
mergeWidth = mergeWidth + .Columns(j).Width
Next j
End With
xScale = (mergeWidth - xSpan * 2) / newPic.Width
yScale = (mergeHeight - ySpan * 2) / newPic.Height
If yScale < xScale Then
myScale = yScale
Else
myScale = xScale
End If
With newPic
.ShapeRange.ScaleWidth myScale, msoTrue, msoScaleFromTopLeft
.Left = targetcell.Left + mergeWidth / 2 - .Width / 2
.Top = targetcell.Top + mergeHeight / 2 - .Height / 2
End With
ActiveCell.Activate
currentSh.Activate
Application.ScreenUpdating = True
End Sub