エクセル VBA 連続して図を取り込み方法 エクセル2013

お世話になります。ご教授、よろしくお願いします。
エクセルにて膨大な行数の商品リスト表があります。
AH列にはJAN.Jpgのコードがあり、そのコードのファイル名を指定の画像格納フォルダからB列に画像を一気に下の行まで貼り付けるVBAを見よう見まねで下記の通り作成しました。結果実行すれば、思う通りにできてよかったのですが、メール送付した取引先に画像が見られないと言われました。
調べると、「Pictures.Insert」は古いバージョンのエクセルで２０１０以降は「Shapes.AddPicture」でやらないと画像リンクのままで他者はリンク切れで見られないとわかりました。
この「Shapes.AddPicture」に書き換えていろいろ試しましたが、どうにもうまくいきませんでした。
どこをどう直せばよいか、お手数ですが、ご教授いただければ幸いです。よろしくお願いします。

Sub macro6()
Dim p As String
Dim h As Range
Dim sp As Shape
'写真の保存場所
p = "\\c:xxx\"
'現在表示されている写真は一度削除する
ActiveSheet.Pictures.Delete

'商品名が入力されている行まで繰り返す
For Each h In Range("AH5:AH" & Range("C1048576").End(xlUp).Row)

'写真ファイルが保存されている時
If Dir(p & h) <> "" Then

With ActiveSheet.Pictures.Insert(p & h)

'写真ファイル名が入力されているセルから３２つ左のセルに挿入

.Top = h.Offset(0, -1).Top
.Left = h.Offset(0, -32).Left

'写真サイズの設定

.Width = h.Offset(0, 1).Width * 0.95
.Height = h.Offset(0, 1).Height * 0.95


.Left = .Left + h.Width / 2 - .Width / 2
.Top = .Top + h.Height / 2 - .Height / 2

End With

End If
Next

End Sub

No.2 ベストアンサー 回答者： fujillin 回答日時： 2020/12/16 15:46

No1です

＞、元画像の縦横比率が変わってしまいました。
＞あと、セルの真ん中に画像を入れるのはどう修正すればよいのでしょうか？
もしかすると、そうなさりたいのかもと推測はしましたが、ご提示のコードは元の画像のプロポーションは無視していますよね？
それなので、細かな言及はしませんでした。
さらには「セルの真ん中」と言いながら、幅や高さを参照しているセルは関係の無いセルになっているので、何をどうしたいのかわからない状態になっています。
（まぁ、高さ方向に関しては、同じ行内のセルを参照しているようなので変わらないのですが）

また、補足でご提示のコードでは、その参照セルが質問文のものとも変わっているようなので、本当は何をしたいのかがわかりません。
多分、同じ行のB列のセルに画像を表示したいのだとろうという事まではわかるのですが、そこから先は不明です。

そもそも、元の画像はサイズがいろいろあるのでしょうか？
（なんとなく一律の様な気がしますが…）
また、シートの各行は高さがいろいろなのでしょうか？
（こちらも一律の様な気が・・・）
もしも、両方とも固定であるならば、固定の比率で表示させれば良くなるので、処理は簡単になります。

画像のサイズもいろいろで縦横比も様々、セルの高さもいろいろであるような場合には、それぞれのセルサイズを調べて、それに合わせて配置する必要が出てきます。
また、その上で、画像の縦横比も維持したい場合には、セルサイズと各辺の比率から適切な拡大（または縮小率）を求める処理も必要になります。
（この場合、表示される画像のサイズは状況に応じてバラバラになります）

セルの中央に画像を表示させる方法は、ご質問文でご提示の方法で宜しいのではないかと思います。
仮に、高さ、幅ともセルの95%に固定なのであれば、TOP、LEFTは高さ（幅）の2.5%の位置に直接表示させれば済みます。
（No1の回答は、この仮定のもとに回答しております）

この回答へのお礼

回答ありがとうございました。お礼返信が遅くなり、申し訳ありませんでした。
今回、最終的に理想のものではありませんが、「サイズ5%」のヒントをいただいたので、画像の縦横サイズの統一、セルサイズの調整で対応できました。

お礼日時：2020/12/21 10:14

No.1 回答者： fujillin 回答日時： 2020/12/16 12:20

こんにちは

https://docs.microsoft.com/ja-jp/office/vba/api/ …

LinkToFileをFalseに、SaveWithDocumentをTrueにしておけば良いのでは？
位置やサイズは必須なので、まとめて指定する必要があります。

ご提示のコードだと、もとの図のプロポーションは関係ないようなので、気にする必要は無いと思いますが、プロポーションを維持したいような場合には、一旦仮置きしてから、ScaleWidthなどを１にすれば元のサイズを取得することが可能です。

この回答へのお礼

ありがとうございます。
下記で修正しましたら、画像が貼付けできました。
しかし、元画像の縦横比率が変わってしまいました。[ScaleWidth]をどのようにあと記述すればいいのでしょうか。
あと、セルの真ん中に画像を入れるのはどう修正すればよいのでしょうか？
お手数ですが、よろしくご教授お願いします。

Sub macro3()
Dim p As String
Dim h As Range
Dim sp As Shape
'写真の保存場所
p = \\C:画像\"
'現在表示されている写真は一度削除する
ActiveSheet.Pictures.Delete

'商品名が入力されている行まで繰り返す
For Each h In Range("AH5:AH" & Range("C1048576").End(xlUp).Row)
'写真ファイルが保存されている時
If Dir(p & h) <> "" Then

ActiveSheet.Shapes.AddPicture _
Filename:=p & h, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=h.Offset(0, -32).Left, _
Top:=h.Offset(0, -1).Top, _
Width:=(h.Offset(0, 0).Width) * 0.95, _
Height:=(h.Offset(0, 0).Height) * 0.95

End If
Next

End Sub

お礼日時：2020/12/16 14:10