VBAを用いた画像一括貼り付けについて

エクセルのVBA勉強中の者です。
現在、「画像挿入」というボタンを作り、そこに以下のマクロを登録しています。

これで画像一括貼り付け自体はできるのですが、
フォルダをコードに打ち込まず(使用者が該当のフォルダの画像を選択する形で)、
順番(左上→右上→下→他)に貼り付けたいのですが、良い方法はないでしょうか。

----

自分の中では、「画像取得」ボタンクリックでパスを取得し、「画像挿入」ボタンでセルに貼り付け。
画像取得はGetOpenFilenameで、じゃまにならないO列あたりにパスを載せて、
以下の画像挿入()のstrPathのところにO列あたりのパスを入れるイメージなのですが、
うまくまとまりません。。。

どなたかお力を貸していただけたら嬉しいです。
よろしくお願いします。


Sub 画像挿入()
Dim shpPic As Shape
Dim strPath As String
strPath = "C:\Users\user\Desktop\test\A001.jpg" '左上
Worksheets(1).Shapes.AddPicture _
Filename:=strPath, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Range("B7").Left, _
Top:=Range("B7").Top, _
Width:=300, _
Height:=300

strPath = "C:\Users\user\Desktop\test\A002.jpg" '右上
Worksheets(1).Shapes.AddPicture _
Filename:=strPath, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Range("E7").Left, _
Top:=Range("E7").Top, _
Width:=200, _
Height:=300

strPath = "C:\Users\user\Desktop\test\A003.jpg" '下
Worksheets(1).Shapes.AddPicture _
Filename:=strPath, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Range("B34").Left, _
Top:=Range("B34").Top, _
Width:=300, _
Height:=300


strPath = "C:\Users\user\Desktop\test\A004.jpg" '他
Worksheets(1).Shapes.AddPicture _
Filename:=strPath, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Range("K34").Left, _
Top:=Range("K34").Top, _
Width:=300, _
Height:=250

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2019/09/16 23:12

＞例えばA1001,A1002,A1004,A1009といったふうに数字が飛ぶときもありますし、

＞文字のところも例えばAAAAやBBBといったふうにバラバラです。

それは、なかなか難儀ですね。

フォルダには貼り付ける4つのファイルだけなのでしょうか？（拡張子が違えば何個でも良いが）
ファイル名は違っても、貼り付けファイルのみなら、
　 If File_Name = "A00" & i & Extension Then　
　 strPath(i) = Folder_Path & File_Name
　 i = i + 1
　 End If
を
If File_Name Like "*" & Extension Then
strPath(i) = Folder_Path & File_Name
i = i + 1
End If
に変えれば良いと思います。

O列に取り敢えず書き出すなら、


Option Explicit
Sub Write_FName()
Dim MaxRow As Long
Dim Folder_Path As String, File_Name As String, Extension As String
Dim i As Long
　 MaxRow = ActiveSheet.Cells(Rows.Count, 15).End(xlUp).Row

　 Extension = ".jpg"
　 With Application.FileDialog(msoFileDialogFolderPicker)
　 　 　 .Title = "　jpg画像の入っているフォルダを選択してください"
　 　 　 .InitialFileName = ThisWorkbook.Path
　 　 　 If .Show = True Then
　 　 　 　 Folder_Path = .SelectedItems(1) & "\"
　 　 　 End If
　 End With
　 If Folder_Path = "" Then Exit Sub
　 File_Name = Dir(Folder_Path & "*" & Extension)
　 i = 1
　 On Error Resume Next
　 Do While File_Name <> ""
　 　 　 If File_Name Like "*" & Extension Then
　 　 　 　 ActiveSheet.Cells(MaxRow + i, "O").Value = Folder_Path & File_Name
　 　 　 　 i = i + 1
　 　 　 End If
　 　 　 If i = 5 Then Exit Do
　 　 　 File_Name = Dir()
　 Loop
End Sub

If i = 5 Then Exit Do を無くせば、jpgのパスとファイル名がすべてが書き出せます。
昇順にする場合は、書き出した後にソートするか、フォルダ内で昇順に並び替えてください。

パス、ファイル名、順番、貼り付け箇所、サイズを表に出来るのであれば、
各設定を条件で配列に入れ運用するのが良いかと思います。
いずれにしても、人が作ったものは、分かり難いと思います。

健闘を祈ります。

この回答へのお礼

Qchan1962 様
浅学非才な私にご丁寧に教えていただきありがとうございます。
ファイルは貼り付けるファイル4つのみでございました。

しかしどうしても上手くいかないようなので、
もう少し自分でやってみて、どうしても上手くいかなかった時に
改めてご質問させていただくことに致します。

貴重なお時間をありがとうございました。
ベストアンサーにさせていただきます。

お礼日時：2019/09/17 00:44

No.1 回答者： Qchan1962 回答日時： 2019/09/16 13:02

＞「画像取得」ボタンクリックでパスを取得し

であれば、下記に示すコード内の
Dim Folder_Path As String
　With Application.FileDialog(msoFileDialogFolderPicker)
　　　.Title = "　jpg画像の入っているフォルダを選択してください"
　　　.InitialFileName = ThisWorkbook.Path
　　　If .Show = True Then
　　　　Folder_Path = .SelectedItems(1) & "\"
　　　End If
　　End With
　　If Folder_Path = "" Then Exit Sub

Folder_Pathを使用して
例
strPath = Folder_Path & "A004.jpg"になります。'他
取り敢えず　大丈夫かと思います。
ただし、指定の画像がない時などには、エラーになります。

時間を持て余していたので、ちょい作です。
やり方は少し違いますが、参考になれば、、
Shapes.AddPictureの設定値を配列に入れて廻す感じです。
ファイル名ソート昇順の部分は、フォルダ内を、名前の昇順で
事前に並び変えをすれば、要りません。
定数（　””　囲っている）は、適時変更してください。

Option Explicit
Sub ShapesAdd()
Dim shpPic As Shape, strPath(4) As String
Dim CellAd As Variant, Wsize As Variant, Hsize As Variant
Dim Folder_Path As String, File_Name As String, Extension As String
Dim temp As Variant, i As Long, j As Long
　 Extension = ".jpg"
　 With Application.FileDialog(msoFileDialogFolderPicker)
　 .Title = "　jpg画像の入っているフォルダを選択してください"
　 .InitialFileName = ThisWorkbook.Path
　 If .Show = True Then
　 Folder_Path = .SelectedItems(1) & "\"
　 End If
　 End With
　 If Folder_Path = "" Then Exit Sub
　 File_Name = Dir(Folder_Path & "*" & Extension)
　 i = 1
　 On Error Resume Next
　 Do While File_Name <> ""
　 If File_Name = "A00" & i & Extension Then　
　 strPath(i) = Folder_Path & File_Name
　 i = i + 1
　 End If
　 If i = 5 Then Exit Do
　 File_Name = Dir()
　 Loop
'--------------ファイル名ソート昇順
　 For i = 1 To UBound(strPath)
　 temp = strPath(i)
　 j = i - 1
　 Do
　 If (j < 0) Then
　 Exit Do
　 End If
　 If (strPath(j) <= temp) Then
　 Exit Do
　 End If
　 strPath(j + 1) = strPath(j)
　 j = j - 1
　 Loop
　 strPath(j + 1) = temp
　 Next
　 '--------------
　　 CellAd = Split("B7,E7,B34,K34", ",")
　　 Wsize = Split("300,200,300,300", ",")
　　 Hsize = Split("300,300,300,250", ",")

　 For i = 1 To UBound(strPath)
　 Worksheets(1).Shapes.AddPicture _
　 Filename:=strPath(i), _
　 LinkToFile:=False, _
　 SaveWithDocument:=True, _
　 Left:=Range(CellAd(i - 1)).Left, _
　 Top:=Range(CellAd(i - 1)).Top, _
　 Width:=CInt(Wsize(i - 1)), _
　 Height:=CInt(Hsize(i - 1))
　 Next
End Sub

この回答へのお礼

ご回答ありがとうございます。


わざわざ作ってくださりありがとうございます。
ファイル名なのですが、今回例として「A001」といった感じにしましたが、
実際はランダムな数列なのです。。。
(番号が若い順に貼っていく点では同じなのですが、
例えばA1001,A1002,A1004,A1009といったふうに数字が飛ぶときもありますし、
文字のところも例えばAAAAやBBBといったふうにバラバラです。
同じフォルダの中の文字は同じなのですが、
違うフォルダでも使えるようにしたいため、どの文字でも対応できるようにしたいのです)

説明しておらず申し訳ありません。

お礼日時：2019/09/16 22:07