insert images form subfolders

[pgujju143]

i am new in marco please help me for insert images folder as well subfolders i have minimum 40 folder as well subfolders i need to insert images with excel cell name without .jpg extension

refer below macro this is work only in folder but i have subfolders images also.

Please help me thanks in advance

Option Explicit

Sub InsertImage_Click()
  Dim sPath As String, s As String, r As Range
  Dim Shp As Shape
  Dim PicRange As Range
  Dim c As Range, cell As Range, sname As String
  Dim diffwidth As Double, diffHeight As Double
  sPath = "D:\Images"
  If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
  Set r = Range("A2", Cells(Rows.Count, "A").End(xlUp))
  For Each cell In r
    cell.Offset(0, 1).Select
    Set c = cell.Offset(0, 1)
    s = sPath & cell.Value & ".jpg" 'remove the .jpg if the cell contains the extension
    sname = Dir(s)
    If sname <> "" Then
    Set PicRange = cell
    Set Shp = ActiveSheet.Shapes.AddPicture(Filename:=s _
        , LinkToFile:=False, SaveWithDocument:=True, Left:=PicRange.Left, Top:=PicRange.Top _
        , Width:=PicRange.Width, Height:=PicRange.Height)
      Shp.ScaleHeight Factor:=0.5, RelativeToOriginalSize:=msoTrue
      Shp.Height = 100
      If Shp.Height > 450 Then
        cell.EntireRow.RowHeight = 450
      Else
        cell.EntireRow.RowHeight = Shp.Height
      End If
      Shp.Left = c.Left
      Shp.Top = c.Top
    End If
  Next
End Sub