任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるようにしようとすると、かなり難易度が高くお手上げ状態です。
このプログラムをどのように改修すれば可能になるかお教えください。

Sub 図11()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可）", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
Range("B6").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置：アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置：アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = ActiveCell.MergeArea.Height
End With

' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル]
ActiveCell.Offset(5).Select

Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True

End Sub

よろしくおねがいします。
※マクロはほぼ初心者です。大体がネットからコピペをして使っている程度のレベルです。

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2015/07/19 18:00

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入

>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため（上限を設定)　という箇所を設けましたが、不要なら、コメント・アウトしてください。また、DoEvents も入れておきました。
④は、何も手を付けていません。
コメント・アウトした部分で不要なら削除してください。

'//
Sub 図11R()
　'No. 9024507
　Dim strFilter As String
　Dim Filenames() As Variant
　Dim fName As Variant, ext As String
　Dim PIC As Picture
　Dim k As Long, m As Long
　Dim i As Long, j As Long
　Dim cnt As Long
　Dim FirstRng As Range
　Dim r As Range
　Dim Sel_Folder As Object, Sel_Path As String
　cnt = 0 'カウントの初期値
　'貼り付け最初のセル
　Set FirstRng = Range("A2")
　
　 Set Sel_Folder = CreateObject("Shell.Application"). _
　　　 BrowseForFolder(0, "フォルダを選択してください", 5)

　　If Not Sel_Folder Is Nothing Then
　　　　Sel_Path = Sel_Folder.Self.Path
　　Else
　　　Exit Sub
　　End If
　
　' 「ファイルを開く」ダイアログでファイル名を取得
　ChDir Sel_Path
'　strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
'　Filenames = Application.GetOpenFilename( _
'　FileFilter:=strFilter, _
'　Title:="図の挿入(複数選択可）", _
'　MultiSelect:=True)
　fName = Dir("*.*", vbNormal)
　Do While fName <> ""
　　If fName <> "." And fName <> ".." Then
　　　ext = Mid(fName, InStrRev(fName, ".") + 1)
　　　If InStr(1, "jpg,jpeg,gif,bmp,png", ext, 1) > 0 And Not fName Like "#*" Then
　　　　cnt = cnt + 1
　　　　DoEvents
　　　　ReDim Preserve Filenames(1 To cnt)
　　　　Filenames(cnt) = fName
　　　 ''安全のため（上限を設定)
　　　　If cnt > 100 Then Exit Do
　　　End If
　　End If
　　fName = Dir()
　Loop
　If cnt = 0 Then Exit Sub
　
　' ファイル名をソート
　Call BubbleSort_Str(Filenames, True, vbTextCompare)
　
　'' 貼り付け開始セルを選択
　'Range("B6").Select
　
　' マクロ実行中の画面描写を停止
　Application.ScreenUpdating = False
　' 順番に画像を挿入
　k = LBound(Filenames)
　m = UBound(Filenames)
　
　For j = 1 To Int(m / 4) + Abs(m Mod 4 > 0)
　　For i = 1 To 4
　　　Set PIC = ActiveSheet.Pictures.Insert(Filenames(k))
　　　Set r = FirstRng.Cells(1 + (j - 1) * 2, i)
　　　
　　　'-------------------------------------------------------------
　　　' 画像の各種プロパティ変更
　　　'-------------------------------------------------------------
　　　With PIC
　　　　.Top = r.Top ' 位置：アクティブセルの上側に重ねる
　　　　.Left = r.Left ' 位置：アクティブセルの左側に重ねる
　　　　.Placement = xlMove ' 移動するがサイズ変更しない
　　　　.PrintObject = True ' 印刷する
　　　End With
　　　With PIC.ShapeRange
　　　　.LockAspectRatio = msoTrue ' 縦横比維持
　　　　' 画像の高さをアクティブセルにあわせる
　　　　' 結合セルの場合でも対応
　　　　.Height = r.MergeArea.Height
　　　End With
　　　
　　　' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル]
　　　' ActiveCell.Offset(5).Select
　　　
　　　Set PIC = Nothing
　　　k = k + 1
　　　If k >= m Then Exit For
　　Next i
　Next j
　Application.ScreenUpdating = True
　ChDir ThisWorkbook.Path
End Sub

この回答へのお礼

WindFallerさま。
ご丁寧な回答をいただきましてありがとうございました！
おかげさまで希望通りのものができるようになり、とてもうれしく思います。
これで、作業効率が１００倍UP！です。
プログラムの中身を見ましたが、全く意味が分かりませんでしたが、これを真似していろいろ工夫しほかにも有効活用させていただきます。
このたびはありがとうございました！

お礼日時：2015/07/21 13:04

No.2 回答者： WindFaller 回答日時： 2015/07/21 14:20

#1の回答者です。

成功してよかったです。
もう一つ、最近、こちらの掲示板でも同様の質問がちらほらでますが、
Pictures.Insert を使うと、
「画像のリンク情報が挿入され、肝心の画像が挿入されていない」
という問題が発生します。

つまり、Excelの画像を埋め込んだファイル自体を、他のPCで使う場合に起こる現象です。

その場合は、代わりに、
Shapes.AddPicture　メソッドを使うようにします。

こちらを参考にしてください。
[AddPictureメソッドで画像を貼りつける]
http://www.moug.net/tech/exvba/0120020.html

この回答へのお礼

WindFallerさま

ご提案いただきましたサイトに移動し試してみましたが、こちらは全くうまくいきませんでした。
最初の myFileName = ActiveWorkbook.Path & "\mogtan.gif"でつまづき、先に進みません。指定フォルダを選択するというプログラムに書き換えなければいけないのかと思い、色々やってみましたが、コピペで何とかなるレベルではないと悟りました。。

ちなみにですが、「ダブルクリックでセルに画像を貼りつける（Pictures.Insertメソッド）」というのがあったので、試してみましたが、メールで送付すると「リンクが切れてます」と出て自分のPC以外では画像が表示されないようでした。
重ね重ねの質問で申し訳ありませんが、これはどうしようもないのでしょうか？どこかを少し調整すると、メールで送付も可能となりますか？
ココにプログラムがありました。
http://www.moug.net/tech/exvba/0120027.html
ご面倒でなければ、お教えください。

お礼日時：2015/07/21 15:53