【VBA】 結合セルに複数画像とファイル名一括挿入する方法

ご覧いただきありがとうございます。
VBA初心者です。
ダイアログボックスを開き画像ファイルを選択、１行目が見出し行になっている表のB2から６行ごとに結合したセルに画像を挿入し、隣のC列(６行ごと結合)に画像ファイル名(拡張子なし)が入る表を作りたいです。
結合していないセルの場合、以下のコードで作成できました。
６行ごとに結合したセルの場合は、どのように修正したらいいのでしょうか？
詳しい方、よろしくお願いいたします。

Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)

With fd
.Title = "Select Image Files"
.Filters.Clear
.Filters.Add "Image Files", "*.GIF; *.JPG; *.BMP; *.PNG; *.TIF", 1
.AllowMultiSelect = True

If .Show = -1 Then
Dim i As Long
For i = 1 To .SelectedItems.Count
Dim fileName As String
fileName = Left(Dir(.SelectedItems(i)), Len(Dir(.SelectedItems(i))) - 4)
Range("C" & i + 1).Value = fileName

Dim Picture As Picture
Set Picture = ActiveSheet.Pictures.Insert(.SelectedItems(i))

With Picture
With .ShapeRange
.LockAspectRatio = msoFalse
.Width = Range("B" & i + 1).Width
.Height = Range("B" & i + 1).Height
End With
.Left = Range("B" & i + 1).Left
.Top = Range("B" & i + 1).Top
.Placement = xlMoveAndSize
End With
Next i
End If
End With
End Sub

No.1 ベストアンサー 回答者： fujillin 回答日時： 2024/10/04 01:09

こんばんは

以下の点を修正すれば対応できると思います。
・対象のセルを6行おきにする
・貼り付ける対象を1セルではなく、.MergeAreaにする

ざっと、こんな感じでしょうか？
※ Withのネストを避ける等多少の変更をしてあります。

Sub Sample()
Dim i As Long, fileName As String
Dim rng As Range, sItems

With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select Image Files"
.Filters.Clear
.Filters.Add "Image Files", "*.GIF; *.JPG; *.BMP; *.PNG; *.TIF", 1
.AllowMultiSelect = True
If .Show = 0 Then Exit Sub
Set sItems = .SelectedItems
End With

For i = 1 To sItems.Count
fileName = Dir(sItems(i))
Set rng = Cells(i * 6 - 4, 2)
rng.Offset(, 1).Value = Left(fileName, InStrRev(fileName, ".") - 1)
Set rng = rng.MergeArea

With ActiveSheet.Pictures.Insert(sItems(i))
.Left = rng.Left
.Top = rng.Top
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Width = rng.Width
.ShapeRange.Height = rng.Height
End With
Next i
End Sub

この回答へのお礼

早速のご回答ありがとうございます可m(_ _)m
イメージ通りでした！
大変助かりました！！

お礼日時：2024/10/04 10:03