PNGをアクティブシートに挿入するマクロについて

質問

Excelマクロブックと同じフォルダ内にある複数のPNGファイル（画像）を、
このマクロブックのアクティブシートに一括で挿入する（場所はどこでも大丈夫です）マクロの書き方を教えて欲しいです。

質問が分かりづらかったら申し訳ありません。
どなたかご教授いただければ幸いです。

回答No.5

SI299792 · ベストアンサー

＞1枚目はセル B53、2枚目はB92・・・と、画像が増えるたびにB53から+39で下に貼っていきたい
これは、最初の質問にある、
（場所はどこでも大丈夫です）
に反しますが、直しました。
Option Explicit
'
Sub Macro1()
　　Dim FileName As String
　　Dim Target As Range
'
　　FileName = Dir(ThisWorkbook.Path & "\" & "*.png")
'
　　If FileName = "" Then
　　　　MsgBox "png ファイルがありません", vbCritical
　　End If
　　ActiveSheet.Pictures.Delete
　　Application.ScreenUpdating = False
　　Set Target = [B53]
'
　　Do While FileName > ""
　　　　ActiveSheet.Shapes.AddPicture ThisWorkbook.Path & "\" & FileName, _
　　　　　　False, True, Target.Left, Target.Top, 525, 399
　　　　Set Target = Target.Offset(39)
　　　　FileName = Dir
　　Loop
End Sub

お礼

確認が遅くなってしまい、大変申し訳ございません。

お教えいただきありがとうございました！無事に処理が実行できました。

回答No.4

SI299792

これだけでは困ります。
・どこでも構わないというのでA1 A2 A3と下に貼っていきます。
他に必要な情報
・直接磔か（png 無くても表示される。他へコピペする時便利、リンク磔か（png が無いと画像が表示されない、メモリーを食わない）［直接磔］
・画像をセルのサイズに合わせるのか［合わせる]
・その時縦横比はどうするのか［変更する]
取りあえず［］の条件で作りました。
（画像は小さく、歪になります）

これらの条件を補足していただければ、変更します。
Option Explicit
'
Sub Macro1()
　　Dim FileName As String
　　Dim Target As Range
'
　　FileName = Dir(ThisWorkbook.Path & "\" & "*.png")
'
　　If FileName = "" Then
　　　　MsgBox "png ファイルがありません", vbCritical
　　End If
　　ActiveSheet.Pictures.Delete
　　Application.ScreenUpdating = False
　　Set Target = [A1]
'
　　Do While FileName > ""
'
　　　　With ActiveSheet.Shapes.AddPicture( _
　　　　　　ThisWorkbook.Path & "\" & FileName, False, True, _
　　　　　　Target.Left, Target.Top, Target.Width, Target.Height)
　　　　End With
　　　　Set Target = Target.Offset(1)
　　　　FileName = Dir
　　Loop
　　MsgBox "終了しました"
End Sub

補足

ご回答いただき誠にありがとうございます。
記載いただいたコード、大変勉強になりました。

こちらの説明に不足な部分が多々あり、申し訳ありません。

以下に、不足していた説明と、追加で実装を希望する部分を記載いたします。

・貼り付ける場所は、画像1枚目はセル B53、2枚目はB92・・・と、画像が増えるたびにB53から+39で下に貼っていきたいです。（分かり辛い説明で申し訳ありません）

・画像は直接貼り付け

・セルのサイズに合わせない

・画像を読み込む際の縦横比は、可能であれば525×399（ピクセル）に変更（縮小）したい（読み込む対象の画像の大きさは全て同じで、640×480ピクセルです）

以上です。
補足が必要な部分がありましたら、お手数ですがお教えいただけますと幸いです。よろしくお願いいたします。

回答No.3

imogasi

#2のついでに、参考で載せてみる。簡単だろう。
下記の注記を参照のこと。想像によるテストです。
これでは都合が合わない場合は、その点を限定・明記して、やり方を質問する、ことだろう。
Sheet2のA列に候補ファイル名のリストを作って後の話。
B列には、不要分は何か印を入力。（プログラムでは判別が難しそうな、質問の説明だから。
ーー
Sub test04()
fld = "C:\Users\XXX\Pictures\"　’ファイルのあるフォルダ名
For i = 1 To 10
If Worksheets("Sheet2").Cells(i, "B") = "" Then
Worksheets("Sheet1").Shapes.AddPicture Filename:=fld & Worksheets("Sheet2").Cells(i, "A"), _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=20, _
Top:=(i - 1) * 210 + 30, _
Width:=300, _
Height:=200
End If
Next i
End Sub
標準モジュールにコピペ。
ーーー
注記
・ファイル指定はフルパスで指定のこと
・B列が空白でない行は、処理をスキップ。リストでスキップするものはB列に何か入力。
・並び順は特に今回は、考えてない
・Height＝２００しているのでTop:=(i - 1) * 210 + 30,　としている
各々の画像の上下余白は、２１０－２００＝１０です
・JPGの１０数個の画像でテストで確認済み
・Shapesの中身が画像という処理です。別途InsertPictureを使う記事もある。

回答No.2

imogasi

この質問を昨日読んで、質問の説明不十分だ、と感じてそのままにした。
本日
＞複数のPNGファイル名に規則性がないため、下記コードの編集方法が分かりませんでした。
を読んだが、規則性がないにしても、どういう選別の仕方をするのか、文章で説明しないと、他人に解るわけがないだろう。
最悪は、シートに、ファイル名のリストを出し、隣列に、要不要のサインを、質問者が判断して、立てるとか、かつ並び順を整えるか、などを決めないとならないだろう。それは質問者の仕事だろう。
こんなことは基本で、それを書いて質問しないと質問にならないだろう。
選別の方法の方が、むしろプログラム的には難しい（不可能）かも。
シートに画像を張り付けるのは、ＷＥＢに例がたくさん載っている。それらを見て、やっってみたのか。やったならやったと書いておけば、回答者はそちらを飛ばして考える。

回答No.1

MT765

自分でコードを書こうと思いましたが良いページがあったのでリンクを貼っておきます。
これで実現できそうでしょうか。

【EXCEL VBA エクセルシートに写真（画像）を挿入する・写真（画像）を表示・写真（画像）を削除（Picture）】
https://akira55.com/image/

補足

ご回答いただきありがとうございます！

早速URL先のコードを参考にしてみたのですが、
挿入したい複数のPNGファイル名に規則性がないため、下記コードの編集方法が分かりませんでした。

With Sheets("Sheet1").Pictures.Insert("C:\DATA\Photo0" & P & ".png")

もしお分かりになりましたら、お手すきの際にお教え頂けますと幸いです。
よろしくお願いいたします。