【EXCEL VBA】ダブルクリックでセルのサイズに合わせて画像を挿入に機能を追加したいです。

はじめまして。ご訪問ありがとうございます。
VBA初心者です。ただいまエクセルを使用し、添付画像の様な商品リストを作成しております。

【商品画像】の項目の列に効率良く画像を挿入したいと思い、下記のマクロを実施しました。
内容は画像を貼り付けたいB列のセル上でダブルクリックすると、ファイルが開き、選択した1枚の画像がセルの大きさに自動でリサイズされ貼り付けられる、とうものです。
※尚このマクロは「なまたまご情報局」さんのサイトを参考にさせていただき少し手を加えました。
http://rawegg.sakuraweb.com/excel-014/

そしてさらに、大量の画像に対応させる為に、指定フォルダの中にある画像を全てを一括で貼り付ける、という機能を追加したいと考えております。
貼り付ける先のセルは、選択中のセルを起点として、画像毎に下に下がって貼り付けて行くという感じです。
※「Programmer's EGG」さんのこのマクロのイメージです。
http://programlife.jugem.jp/?eid=48

今のマクロにどの様に追記すれば良いか教えていただきたく、どうぞよろしくお願いいたします。

------------------------

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myF As Variant
Dim mySp As Object
Dim myAD1 As String
Dim myAD2 As String
Dim myHH As Double
Dim myWW As Double
Dim myHH2 As Double
Dim myWW2 As Double

If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub

Cancel = True



'画像選択コマンド
myF = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If myF = False Then
MsgBox "画像を選んで下さい(終了します)"
Exit Sub
End If
'画像データの再構築
For Each mySp In ActiveSheet.Shapes
myAD1 = mySp.TopLeftCell.MergeArea.Address
myAD2 = Target.Address
If myAD1 = myAD2 Then mySp.Delete
Next
'リサイズして画像の貼り付け
Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=0, Height:=0)
mySp.ScaleHeight 1, msoTrue
mySp.ScaleWidth 1, msoTrue
'縮尺を変えずにリサイズ
If mySp.Width > Target.Width Then mySp.Width = Target.Width * 0.99
If mySp.Height > Target.Height Then mySp.Height = Target.Height * 0.99
'センター中心に配置
myHH2 = (Target.Height / 2) - (mySp.Height / 2)
myWW2 = (Target.Width / 2) - (mySp.Width / 2)
mySp.Top = Target.Top + myHH2
mySp.Left = Target.Left + myWW2

Set mySp = Nothing

End Sub

------------------------

No.1 ベストアンサー 回答者： ママチャリ 回答日時： 2017/09/30 11:53

簡単に直すなら、こんな感じでしょうか。

ちなみに、「画像の選択」画面で複数のファイルを選択できるようにしただけなので、自力ですべてのファイルを選択する必要があります。「画像の選択」画面から「整理」-「すべて選択」で選択できるので、それほど手間ではないですが・・・。ちなみに、サブフォルダも選択されますが、処理的には無視されるので問題ないです。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myFs As Variant
Dim myF As Variant
Dim mySp As Object
Dim myAD1 As String
Dim myAD2 As String
Dim myHH As Double
Dim myWW As Double
Dim myHH2 As Double
Dim myWW2 As Double

If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub

Cancel = True

'画像選択コマンド
myFs = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , True)
If IsArray(myFs) = False Then
MsgBox "画像を選んで下さい(終了します)"
Exit Sub
End If
'画像データの再構築
For Each myF In myFs
For Each mySp In ActiveSheet.Shapes
myAD1 = mySp.TopLeftCell.MergeArea.Address
myAD2 = Target.Address
If myAD1 = myAD2 Then mySp.Delete
Next
'リサイズして画像の貼り付け
Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=0, Height:=0)
mySp.ScaleHeight 1, msoTrue
mySp.ScaleWidth 1, msoTrue
'縮尺を変えずにリサイズ
If mySp.Width > Target.Width Then mySp.Width = Target.Width * 0.99
If mySp.Height > Target.Height Then mySp.Height = Target.Height * 0.99
'センター中心に配置
myHH2 = (Target.Height / 2) - (mySp.Height / 2)
myWW2 = (Target.Width / 2) - (mySp.Width / 2)
mySp.Top = Target.Top + myHH2
mySp.Left = Target.Left + myWW2

Set mySp = Nothing
Set Target = Target.Offset(1)
Next myF

End Sub

この回答へのお礼

ママチャリ様
はじめまして。この度はお忙しい中ご丁寧にご教示いただきまして、ありがとうございました！
m(_ _)m
教えていただきましたマクロの適用で、画像添付の作業時間が大幅に削減され感無量です！
今後もVBAを勉強して、便利なマクロが組める様に努力していきたいと思います。
また機会がございましたら、よろしくお願いいたします☆☆☆

お礼日時：2017/09/30 19:31