任意フォルダ選択、画像名隣に画像貼り付け

商品リストを作っています。

エクセルシートのA4,C4,E4,A8,C8,E8画像名が入っています。（たとえば18001,18002,・・・）
任意選択フォルダ内にある「18001､18002,・・・」の画像ファイルの貼り付け方を教えてください。

動作としては「マクロ起動→フォルダ任意選択→シート画像名の隣に画像を自動で貼り付け」を
行いたいのですがどうすればいいですか？

マクロはド初心者です。切り貼りくらいしか出来ません。

検索して下記の方法を見つけたのですが、画像フォルダが指定してあります。
下記の方法で任意フォルダ選択に変更したいのですがマクロをどのように
変更したら良いのか教えて下さい。


Sub macro1()
Dim p As String
Dim h As Range

'写真の保存場所
p = "C:\Users\☆☆☆\Documents\picpic\"

'現在表示されている写真は一度削除する
ActiveSheet.Pictures.Delete

'商品名が入力されている行まで繰り返す
For Each h In Range("A4,C4,E4,A8,C8,E8" & Range("Z4,Z8").End(xlShiftToRight))

'写真ファイルが保存されている時
If Dir(p & h) <> "" Then
With ActiveSheet.Pictures.Insert(p & h)
.Name = h
'写真ファイル名が入力されているセルから２つ左のセルに挿入
.Top = h.Offset(0, -2).Top
.Left = h.Offset(0, -2).Left
'写真サイズの設定
.Width = h.Offset(0, 1).Width
.Height = h.Offset(0, 1).Height
End With
End If
Next
End Sub

質問者からの補足コメント

• 回答ありがとうございます。
  補足いたします。
  ①下記のTop,Leftで表示位置を調整したいと考えております。
  　.Top = h.Offset(0, 0).Top
  　.Left = h.Offset(0, 1).Left
  ②画像拡張子
  　　Jpgのみです。
  
  ③画像名を記述する場所
  　　画像数８－２０枚の貼り付けを考えており
  　　追加の場合、下記に追加してしようすることを考えております。
  　For Each h In Range("A4,C4,E4,A8,C8,E8" & Range("Z4,Z8").End(xlShiftToRight))
  現在①、③は数字変更追加をすることで対応を考えており、②は.jpgを画像名の後ろにつけ
  画像を読み込んでおります（2018002.jpg）ので出来れば.jpgを入力せずに画像名のみでの
  読み込み貼り付けたいです。

  
    補足日時：2018/09/23 11:38

No.2 ベストアンサー 回答者： tatsu99 回答日時： 2018/09/23 16:48

以下のようにしてください。

とりあえず、画像名が記述されたセルの下に画像を表示しています。
最初に表示されるフォルダは、このマクロが格納されたexcelのフォルダです。
-----------------------------------------------
Sub macro1()
Dim p As String
Dim h As Range
Dim name As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
If .Show = -1 Then
p = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
'写真の保存場所
'p = "C:\Users\☆☆☆\Documents\picpic\"
'現在表示されている写真は一度削除する
ActiveSheet.Pictures.Delete

'商品名が入力されている行まで繰り返す
'For Each h In Range("A4,C4,E4,A8,C8,E8" & Range("Z4,Z8").End(xlShiftToRight)) 'これは期待した動作をしない
For Each h In Range("A4,C4,E4,A8,C8,E8,Z4,Z8")
'写真ファイルが保存されている時
name = h.Value & ".jpg"
If h.Value <> "" And Dir(p & name) <> "" Then
With ActiveSheet.Pictures.Insert(p & name)
.name = h.Value
'写真ファイル名が入力されているセルから２つ左のセルに挿入
.Top = h.Offset(1, 0).Top
.Left = h.Offset(1, 0).Left
'写真サイズの設定
.Width = h.Offset(0, 1).Width
.Height = h.Offset(0, 1).Height
End With
End If
Next
End Sub

この回答へのお礼

tatsu99さん
回答本当にありがとうございます。
マクロ実行したところ、希望通りに画像を貼りつけることが
出来ました。

お礼日時：2018/09/23 17:36

No.1 回答者： tatsu99 回答日時： 2018/09/23 10:33

補足要求です。

①あなたが提示されたマクロをみると、名前の書いてあるセルの２つ左の箇所に画像を配置するようになっています。
例えば、C4に18002が記述されていると、A4にその画像が配置されます。
そうすると、元々のA4の箇所に記述された画像名が壊れてしまします。（添付図参照）
C４に画像名があった時、あなたは、その画像をどこに配置されたいのでしょうか。

②画像名の拡張子は何でしょうか？
jpg、png、bmp等があります。
通常、ファイル名を指定する場合は、拡張子まで含めて指定するのですが、
もし、18002のように記述するなら、拡張子は例えばjpgのように決め打ちする必要があります。

③画像名を記述する箇所は、本当に
A4、C4、E４
A8、C8、E8
だけで良いのでしょうか。
今後、更に追加したいという要望が発生したとき、問題ないのでしょうか。

この回答へのお礼

細かな所までご確認頂きありがとうございます。

お礼日時：2018/09/23 17:37