エクセルのマクロで、複数の写真をセルの中央に

質問

エクセルのマクロにて下記のようなことをしたいと思っています。
ご教授お願いします。

なお、以前に出ていた回答をベースにしたいと考えています。そのコードも下記に載せておきます。

やりたいこと
(1).複数の写真がある
(2).1枚目の写真はB1に貼り付けている
(3).同様にn枚目の写真はBnに貼り付けている（今現在300枚、今後増える予定）

ここまではもうやっています。この後が問題なのですが
(4).Bnのセルの中で、写真をセルの中央に移動させたい

この(4)ができず困っています。既出で参考にした回答は下記です。
下記に手を加えていただき、(4)ができるようにしていただければ助かるのですが。
よろしくお願いいたします。

http://okwave.jp/qa/q3875596.html

参考にしたコード

Sub picCenter()
Dim p As Object
Dim rng, trg As Range
Const adr As String = "A26"　'処理対象セルの左上のアドレス
　　If Range(adr).MergeCells Then
　　　　Set rng = Range(adr).MergeArea
　　Else
　　　　Set rng = Range(adr)
　　End If
　　For Each p In ActiveSheet.Pictures
　　　　Set trg = Intersect(rng, p.TopLeftCell)
　　　　If Not trg Is Nothing Then
　　　　　　If p.Width < rng.Width Then
　　　　　　　　p.Left = rng.Left + (rng.Width - p.Width) / 2
　　　　　　End If
　　　　　　If p.Height < rng.Height Then
　　　　　　　　p.Top = rng.Top + (rng.Height - p.Height) / 2
　　　　　　End If
　　　　End If
　　Next p
End Sub

この中の

Const adr As String = "A26"　'処理対象セルの左上のアドレス

という箇所を、for-next関数でたとえばi=1からi=500とし
セル番地Biで実行したらいいと思うのですが。

回答No.1

tsubuyuki · ベストアンサー

>この中の
> Const adr As String = "A26"　'処理対象セルの左上のアドレス
> という箇所を、for-next関数でたとえばi=1からi=500とし
> セル番地Biで実行したらいいと思うのですが。

それでも問題ないです。
あとは実践ですね、がんばりましょう。

とりあえず、Constを消して、
　　　　For i = 1 To ActiveSheet.Pictures.Count
　　　　　　　　Set rng = Cells(i, 2)
　　　　　　　　～処理～
　　　　Next
で良いんじゃないかなと思います（未検証ですが）。

無駄を省きたいなら考え方をちょっとだけ変えて
「全ての写真において、写真があるセル番地の中心に」とします。
ご提示のコードを活かすなら

Sub sample()
Dim p As Object
Dim trg As Range
　　　　For Each p In ActiveSheet.Pictures
　　　　　　　　Set trg = Range(p.TopLeftCell.Address)
　　　　　　　　If Not trg Is Nothing Then
　　　　　　　　　　　　If p.Width < trg.Width Then
　　　　　　　　　　　　　　　　p.Left = trg.Left + (trg.Width - p.Width) / 2
　　　　　　　　　　　　End If
　　　　　　　　　　　　If p.Height < trg.Height Then
　　　　　　　　　　　　　　　　p.Top = trg.Top + (trg.Height - p.Height) / 2
　　　　　　　　　　　　End If
　　　　　　　　End If
　　　　Next p
End Sub

こんな感じ。
ただしこれは
「全ての写真が目的のセル番地（Ｂｎセルでしたっけ）内に正しく収まっている場合」
に限ります。

これが
「シート内にバラバラに配置されている複数の写真を
　Ｂ列各行に１枚ずつ整然と配置したい」
のであれば

Sub sample2()
Dim p As Object
Dim rng, trg As Range
　　　　For i = 1 To ActiveSheet.Pictures.Count
　　　　　　　　Set p = ActiveSheet.Pictures(i)
　　　　　　　　Set trg = Cells(i, 2)
　　　　　　　　If Not trg Is Nothing Then
　　　　　　　　　　　　If p.Width < trg.Width Then
　　　　　　　　　　　　　　　　p.Left = trg.Left + (trg.Width - p.Width) / 2
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　p.Left = trg.Left
　　　　　　　　　　　　End If
　　　　　　　　　　　　If p.Height < trg.Height Then
　　　　　　　　　　　　　　　　p.Top = trg.Top + (trg.Height - p.Height) / 2
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　p.Top = trg.Top
　　　　　　　　　　　　End If
　　　　　　　　End If
　　　　Next
End Sub

まだ贅肉が多いですが、動くと思いますよ。
写真の幅・高さがセルより大きい場合はセルの左・上に合うように加筆しています。

お礼

tsubuyukiさま

ありがとうございました。最終的には２つ目の方法で処理を進めています。３つ目も私には目からうろこのコードであり、
土日にゆっくりと研究させていただきます。

実践を積んで、少しでもスキル向上していきたいと思います。
ありがとうございました。