【エクセルVBA】写真挿入の2枚目がうまくいかない

自己流でやっており下手なコードです・・・お知恵を拝借できればと思います！
アクディブセルを選択、写真挿入して複数枚の場合は隣のセルへ貼りつけのコードはできました。
これを指定セル2つに配置(E8とE9)にしようとしましたが、E8に写真が二枚貼りつけになってしまいました・・・
どこを変更したらいいのか、ご教授いただければ幸いです。

Sub 写真入れる()

Dim fName As Variant
Dim i As Long
Dim Pict As Picture

fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True)
If IsArray(fName) Then
Application.ScreenUpdating = False
'配列に格納されたファイル名をソート
BubbleSort fName, True

For i = 1 To UBound(fName)
Set Pict = ActiveSheet.Pictures.Insert(fName(i))

With Pict
.Top = Range("E8").Top '画像の上位置
.Left = Range("E8").Left '画像の左位置
.Width = Range("E8").Width 'セルの幅にリサイズ
End With

' 次の貼り付け先を選択（アクティブセルにする）
Select Case i Mod 1
Case 1 '次の写真（0,前の写真の何個下かを指定）
ActiveCell.Offset(1, 0).Select
End Select

Next i
End If
With Application
.StatusBar = False
.ScreenUpdating = True
End With
Set Pict = Nothing
MsgBox i - 1 & "枚の画像を挿入しました｡", vbInformation

End Sub

No.1 ベストアンサー 回答者： ぽち101 回答日時： 2021/05/05 15:13

これでどうでしょうか？

Sub 写真入れる()

Dim fName As Variant
Dim i As Long
Dim Pict As Picture

fName = Application.GetOpenFilename("JPGファイル, *.jpg", MultiSelect:=True)
If IsArray(fName) Then
Application.ScreenUpdating = False
'配列に格納されたファイル名をソート
BubbleSort fName, True

For i = 1 To UBound(fName)
Set Pict = ActiveSheet.Pictures.Insert(fName(i))

'---ここから追加分1
Dim myCol As String
Dim myRow As Long
myCol = "E" '列の
myRow = "8" '行目から貼り付け開始
'ここまで追加分1---

With Pict
'---ここから変更1
.Top = Range(myCol & myRow + i).Top '画像の上位置
.Left = Range(myCol & myRow + i).Left '画像の左位置
.Width = Range(myCol & myRow + i).Width 'セルの幅にリサイズ
'ここまで変更1---
'---ここから追加分2
.Height = Range(myCol & myRow + i).Height 'セルの高さにリサイズ
'ここまで追加分2---
End With

' 次の貼り付け先を選択（アクティブセルにする）
Select Case i Mod 1
Case 1 '次の写真（0,前の写真の何個下かを指定）
ActiveCell.Offset(1, 0).Select
End Select

Next i
End If
With Application
.StatusBar = False
.ScreenUpdating = True
End With
Set Pict = Nothing
MsgBox i - 1 & "枚の画像を挿入しました｡", vbInformation

End Sub

この回答へのお礼

出来ました！
なるほど、+iを使う感じですね
早急かつ欲しかった動作をありがとうございます！
助かりました(*'ω'*)/

お礼日時：2021/05/05 15:35