こんばんは
JPEGのファイル名をそのまま記入する方法はありますか？
今は自動でナンバーです



Sub ()
    Dim s As String, ss As String
    Dim sn As Long
    Dim Pic As Shape
    Dim x As Long, y As Long, z As Long
    Const cRows As Long = 19
    Const cCols As Long = 5
    Const iyMax As Long = 3
    Const sPath As String = "C:\写真\"
    Dim fNum() As Long
    Dim i As Long, j As Long, k As Long
    Dim rngArea As Range
    
    s = Dir(sPath & "*.jpg")
    Do Until s = ""
        If CLng(Val(s)) > 0 Then
            i = i + 1
            ReDim Preserve fNum(1 To i)
            fNum(i) = CLng(Val(s))
        End If
        s = Dir()
    Loop
    If i > 0 Then
        ShellSort fNum
        ActiveSheet.DrawingObjects.Delete
        ActiveSheet.UsedRange.Clear
        
        Set rngArea = Range("A1:U54")
        z = 0
        For j = 1 To i Step 12
            y = 0: x = 0
            For k = j To WorksheetFunction.Min(j + 11, i)
                If fNum(k) < 10 Then ss = "0" Else ss = ""
                s = ss & fNum(k) & ".jpg"
                
                Set Pic = ActiveSheet.Shapes.AddPicture(Filename:=sPath & s, LinkToFile:=False, SaveWithDocument:=True, _
                          Left:=0, Top:=0, Width:=-1, Height:=-1)
                
                With rngArea.offset(z * rngArea.Rows.Count).Cells( _
                    y * cRows + 2, x * cCols + 1).Resize(cRows - 4, cCols)

                    Pic.Left = .Left
                    Pic.Top = .Top
                    If ((.Width - 3) / (.Height - 3)) > _
                            ((Pic.Width) / (Pic.Height)) Then
                        Pic.Height = .Height - 3
                    Else
                        Pic.Width = .Width - 3
                    End If
                    
        
        .Cells(0, 1).Value = "'" & Split(s, ".")(0)
        .Cells(0, 1).Font.Name = "ＭＳ ゴシック" ' フォントをＭＳゴシックに
        .Cells(0, 1).Font.size = 20 ' フォントのサイズを 20 に
            
                End With
                y = y + 1
                If iyMax <= y Then
                    y = 0
                    x = x + 1
                End If
            Next k
            z = z + 1
        Next
        Set rngArea = Nothing
        Erase fNum
    Else
        MsgBox sPath & " に JPG ファイルはありません"
    End If
End Sub

Private Sub ShellSort(MyAry() As Long)
    Dim i As Long, j As Long
    Dim MyMid As Long
    Dim MyTmp As Long
    Dim MyMin As Long
    Dim MyMax As Long
    
    MyMin = LBound(MyAry)
    MyMax = UBound(MyAry)
    MyMid = 1
    Do While MyMid < (MyMax - MyMin + 1) \ 3
        MyMid = 3 * MyMid + 1
    Loop
    Do Until MyMid <= 0
        For i = MyMid + MyMin To MyMax
            MyTmp = MyAry(i)
            For j = i To MyMid + MyMin Step -MyMid
                If MyAry(j - MyMid) <= MyTmp Then
                    Exit For
                End If
                MyAry(j) = MyAry(j - MyMid)
            Next j
            MyAry(j) = MyTmp
        Next i
        MyMid = MyMid \ 3
    Loop
End Sub