Microsoft Excel - Search Folders for pictures and insert

So my problem is that I am able to search for pictures right now but only in a specified folder.  I was wondering if it was possible to search a folder and its subfolders.  Here is the code i have so far.

Sub Picture2()
 jason = InputBox("Enter the path of the folder that the pictures are stored in")
 Dim picname As String
 
 Dim pasteAt As Integer
 Dim lThisRow As Long

   
    lThisRow = 2

    Do While (Cells(lThisRow, 3) <> "")
  
      pasteAt = lThisRow
      Cells(pasteAt, 1).Select     
      'Dim picname As String
     picname = Cells(lThisRow, 3) 
      On Error Resume Next
     
    
 
      ActiveSheet.Pictures.Insert("Jason" & picname & ".jpg").Select 
      With Selection
        '.Left = Range("A6").Left
        '.Top = Range("A6").Top
        .Left = Cells(pasteAt, 1).Left
        .Top = Cells(pasteAt, 1).Top
       
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 100#
        .ShapeRange.Width = 80#
        .ShapeRange.Rotation = 0#
      End With
     
      lThisRow = lThisRow + 1
   
    Loop
   
    Range("A10").Select
    Application.ScreenUpdating = True
   

End Sub

Try using this below function, it can also filter for specific files

Option Explicit 
 
Sub SrchForFiles() 
     ' Searches the selected folders and sub folders for files with the specified
     'extension.  .xls, .doc, .ppt, etc.
     'A new worksheet is produced called "File Search Results".  You can click on the link and go directly
     'to the file you need.
    Dim i As Long, z As Long, Rw As Long 
    Dim ws As Worksheet 
    Dim y As Variant 
    Dim fLdr As String, Fil As String, FPath As String 
     
    y = Application.InputBox("Please Enter File Extension", "Info Request") 
    If y = False And Not TypeName(y) = "String" Then Exit Sub 
    Application.ScreenUpdating = False 
     '**********************************************************************
     'fLdr = BrowseForFolderShell
    With Application.FileDialog(msoFileDialogFolderPicker) 
        .Show 
        fLdr = .SelectedItems(1) 
    End With 
     '**********************************************************************
    With Application.FileSearch 
        .NewSearch 
        .LookIn = fLdr 
        .SearchSubFolders = True 
        .Filename = y 
        Set ws = ThisWorkbook.Worksheets.Add(Sheets(1)) 
        On Error Goto 1 
        2:              ws.Name = "FileSearch Results" 
        On Error Goto 0 
        If .Execute() > 0 Then 
            For i = 1 To .FoundFiles.Count 
                Fil = .FoundFiles(i) 
                 'Get file path from file name
                FPath = Left(Fil, Len(Fil) - Len(Split(Fil, "\")(UBound(Split(Fil, "\")))) - 1) 
                If Left$(Fil, 1) = Left$(fLdr, 1) Then 
                    If CBool(Len(Dir(Fil))) Then 
                        z = z + 1 
                        ws.Cells(z + 1, 1).Resize(, 4) = _ 
                        Array(Dir(Fil), _ 
                        FileLen(Fil) / 1000, _ 
                        FileDateTime(Fil), _ 
                        FPath) 
                        ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _ 
                        Address:=.FoundFiles(i) 
                    End If 
                End If 
            Next i 
        End If 
    End With 
     
    ActiveWindow.DisplayHeadings = False 
     
    With ws 
        Rw = .Cells.Rows.Count 
        With .[A1:D1] 
            .Value = [{"Full Name","Kilobytes","Last Modified", "Path"}] 
            .Font.Underline = xlUnderlineStyleSingle 
            .EntireColumn.AutoFit 
            .HorizontalAlignment = xlCenter 
        End With 
        .[E1:IV1 ].EntireColumn.Hidden = True 
        On Error Resume Next 
        Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden = True 
        Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo 
    End With 
     
    Application.ScreenUpdating = True 
    Exit Sub 
    1:      Application.DisplayAlerts = False 
    Worksheets("FileSearch Results").Delete 
    Application.DisplayAlerts = True 
    Goto 2 
End Sub 

Sub SrchForFiles()
   ' Searches the selected folders and sub folders for files with the specified
   'extension.  .xls, .doc, .ppt, etc.
   'A new worksheet is produced called "File Search Results".  You can click on the link and go directly
   'to the file you need.
    Dim i As Long, z As Long, Rw As Long
    Dim ws As Worksheet
    Dim y As Variant
    Dim fLdr As String, Fil As String, FPath As String
    Dim picname As String
    Dim pasteAt As Integer
    Dim lThisRow As Long
   
      lThisRow = 2

    Do While (Cells(lThisRow, 3) <> "")
   
    pasteAt = lThisRow
      Cells(pasteAt, 1).Select
      picname = Cells(lThisRow, 3)
      On Error Resume Next
     
    Application.ScreenUpdating = False

    With Application.FileSearch
      .NewSearch
      .LookIn = "J:\Int'l Growth Strategy\IGS Images\Portal-Ready\"
      .SearchSubFolders = True
      .Filename = picname & "*" & ".jpg"
      On Error GoTo 1
2:
      On Error GoTo 0
      If .Execute() > 0 Then
        For i = 1 To .FoundFiles.Count
          Fil = .FoundFiles(i)
         'Get file path from file name
          FPath = Left(Fil, Len(Fil) - Len(Split(Fil, "\")(UBound(Split(Fil, "\")))) - 1)
          If Left$(Fil, 1) = Left$(fLdr, 1) Then
            If CBool(Len(Dir(Fil))) Then
              z = z + 1
              ws.Cells(z + 1, 1).Resize(, 4) = _
              Array(Dir(Fil), _
              FileLen(Fil) / 1000, _
              FileDateTime(Fil), _
              FPath)
              ws.Hyperlinks.Add Anchor:=Cells(z + 1, 1), _
              Address:=.FoundFiles(i)
            End If
          End If
        Next i
      End If
    End With
  
    ActiveWindow.DisplayHeadings = False
  
    With ws
      Rw = .Cells.Rows.Count
      With .[A1:D1]
        .Value = [{"Full Name","Kilobytes","Last Modified", "Path"}]
        .Font.Underline = xlUnderlineStyleSingle
        .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
      End With
      .[E1:IV1 ].EntireColumn.Hidden = True
      On Error Resume Next
      Range(Cells(Rw, "A").End(3)(2), Cells(Rw, "A")).EntireRow.Hidden = True
      Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], xlAscending, Header:=xlNo
    End With
         lThisRow = lThisRow + 1
   
    Loop
   
    Application.ScreenUpdating = True
    Exit Sub
1:      Application.DisplayAlerts = False
    Worksheets("FileSearch Results").Delete
    Application.DisplayAlerts = True
    GoTo 2
   

End Sub

It looks like you are specifying the name of the picture, would you rather just have it find all the .jpg files and paste them in, then update the path in column c?

Try this:

You will need to set a reference to the Windows Script Host Object Model in the VBA IDE (Tools, References, then scroll down to find it), and change the path in the StartImport routine to your own path.