Excelで該当の画像ファイル張り付るVBAは？

質問

Excelで雛形のシートを複製して名前を変更し、該当する画像を指定したセルに張り付けるVBAを教えて頂けないでしょうか？

「現場写真」というフォルダ内に、下記の画像が入っています。
・　現場写真13-1.jpg
・　現場写真13-2.jpg
・　現場写真14-1.jpg
・　現場写真14-2.jpg
・　現場写真15-1.jpg
・　現場写真15-2.jpg
・　現場写真15-3.jpg

雛形のエクセルシートに「現場写真」というシートがあり、そのシートを複製し、シート名を「現場写真13」、「現場写真14」、「現場写真15」に変えて該当の写真を張り付けたいのです。
(雛形のシートの複製が難しいなら、新規シートを作成して、名前を変えるのでもOKです。)

張り付ける場所は、一枚目をA1、二枚目をA46、三枚目をA91にしたいです。（一枚目以外は、前の画像から２行あいた位置に入ればOKです）

アドバイスよろしくお願いします。

回答No.1

keithin · ベストアンサー

淡々と。

sub macro1()
　dim myPath as string
　dim myFile as string
　dim a as variant, b as variant

’初期化
　a = array("","A1","A46","A91")
　mypath = "C:\不明の場所の\現場写真\
　'または
　'mypath = thisworkbook.path & "\現場写真\"
　on error goto errhandle

’画像ファイルの調査開始
　myfile = dir(mypath & "*.jpg")
　do until myfile = ""
　　b = split(myfile, "-")
　　worksheets(b(0)).activate

　’画像の挿入
　　with activesheet.pictures.insert(mypath & myfile)
　　.top = range(a(val(b(1)))).top
　　.left = range(a(val(b(1)))).left
　’.width = 指定無し
　’.height = 指定無し
　　end with
　　myfile = dir()
　loop
　exit sub

errhandle:
’シートの複製
　worksheets("現場写真").copy after:=worksheets(worksheets.count)
　activesheet.name = b(0)
　resume
end sub

お礼

アドバイスありがとうございます！

素晴らしい！完璧です！凄すぎます！
自分も勉強してこういうのができるようになりたいです。

勉強するのに何か良いサイトや本があるのでしょうか？

回答No.4

jcctaira

No.2です。

> With Application.FileSearch　の部分が黄色くなってしまいうまく機能しませんでした。

EXCEL2003までは問題なく動きます。
多分EXCEL2007かEXCEL20010を使用していると思います。

正直かなり便利なコマンドでしたが、NO.1のkeithinさんのようにDIR()関数か
「Scripting.FileSystemObject」クラスに変更する必要があります。
すでに解決しているようなので、今回は省略させて頂きます。

回答No.3

某HN クロメート(Chromate)（@CoalTar）

VBAは苦手なので、こんなファイルを使っています
http://lonewolf.chu.jp/

お礼

アドバイスありがとうございます。
こういうのがあるの知りませんでした。
大変参考になりました。

回答No.2

jcctaira

redcurbさん
こんにちは。

以下のプログラムでできると思います。
お試しください。

Sub 画像セット()
　Const 検索フォルダ = "C:\現場写真"
　Dim I　　　 As Long
　Dim F　　　 As Long
　Dim 写真名　As String
　For I = 13 To 15
　　写真名 = "現場写真" & I
　　Sheets("現場写真").Copy After:=Sheets(Sheets.Count)
　　ActiveSheet.Name = 写真名
　　With Application.FileSearch
　　　.NewSearch
　　　.SearchSubFolders = True　　　　''サブフォルダも検索する
　　　.LookIn = 検索フォルダ
　　　.Filename = 写真名 & "*.jpg"
　　　.Execute
　　　 For F = 1 To .FoundFiles.Count
　　　　 Cells((F - 1) * 45 + 1, "A").Select
　　　　 ActiveSheet.Pictures.Insert (.FoundFiles(F))
　　　 Next F
　　End With
　Next I
End Sub

お礼

アドバイスありがとうございます。

With Application.FileSearch　の部分が黄色くなってしまいうまく機能しませんでした。