Here are tghe code,
Public Sub FilesInSubFolders()
Dim i As Long
Dim diaFolder As FileDialog
Dim rng As Range
Dim shp As Shape
Dim strRootDir As String, strMsg As String
Dim arrFiles As Variant, arrRanges As Variant
'load the ranges & associated files in two arrays of the same length:
arrFiles = Array("Near_S1_DL.png", "Near_S1_UL.png", "Near_S1_AttachDettach_Ping.png", "Near_S1_MOC_1.png", "Near_S1_MOC_2.png", "Near_S1_MTC_1.png", "Near_S1_MTC_2.png", _
"Near_S2_DL.png", "Near_S2_UL.png", "Near_S2_AttachDettach_Ping.png", "Near_S2_MOC_1.png", "Near_S2_MOC_2.png", "Near_S2_MTC_1.png", "Near_S2_MTC_2.png", _
"Near_S3_DL.png", "Near_S3_UL.png", "Near_S3_AttachDettach_Ping.png", "Near_S3_MOC_1.png", "Near_S3_MOC_2.png", "Near_S3_MTC_1.png", "Near_S3_MTC_2.png")
arrRanges = Array(Sheets("Sector_Near POINT").Range("B8"), Sheets("Sector_Near POINT").Range("N8"), Sheets("PING Near_Far point ").Range("B8"), Sheets("CSFB_MOC & Reselection S1 S2 S3").Range("B7"), Sheets("CSFB_MOC & Reselection S1 S2 S3").Range("N7"), Sheets("CSFB_MTC & Reselection S1 S2 S3").Range("B7"), Sheets("CSFB_MTC & Reselection S1 S2 S3").Range("N7"), _
Sheets("Sector_Near POINT").Range("B43"), Sheets("Sector_Near POINT").Range("N43"), Sheets("PING Near_Far point ").Range("B33"), Sheets("CSFB_MOC & Reselection S1 S2 S3").Range("B33"), Sheets("CSFB_MOC & Reselection S1 S2 S3").Range("N33"), Sheets("CSFB_MTC & Reselection S1 S2 S3").Range("B33"), Sheets("CSFB_MTC & Reselection S1 S2 S3").Range("N33"), _
Sheets("Sector_Near POINT").Range("B77"), Sheets("Sector_Near POINT").Range("N77"), Sheets("PING Near_Far point ").Range("B58"), Sheets("CSFB_MOC & Reselection S1 S2 S3").Range("B59"), Sheets("CSFB_MOC & Reselection S1 S2 S3").Range("N59"), Sheets("CSFB_MTC & Reselection S1 S2 S3").Range("B59"), Sheets("CSFB_MTC & Reselection S1 S2 S3").Range("N59"))
If UBound(arrFiles) <> UBound(arrRanges) Then
MsgBox ("Dev Check: Unequal number of files & ranges specified.")
Exit Sub
End If
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
diaFolder.Show
strRootDir = diaFolder.SelectedItems(1)
For i = LBound(arrFiles) To UBound(arrFiles)
gblStrPathAndFile = ""
gblStrFileToFind = arrFiles(i)
'starting in the root directory, search for each file - set the full path name if found:
Call GetSubDirectories(strRootDir)
If gblStrPathAndFile <> "" Then
Set rng = arrRanges(i)
With rng.MergeArea
Set shp = Worksheets(rng.Parent.Name).Shapes.AddPicture(Filename:=gblStrPathAndFile, linkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
shp.LockAspectRatio = msoFalse
End With
Set rng = Nothing
Set shp = Nothing
End If
Next i
End Sub
Sub GetSubDirectories(strFolder As String)
Dim objFileSystem As Object, objFolder As Object, objSubFolder As Object
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strFolder)
Call GetFiles(objFolder.Path)
If gblStrPathAndFile <> "" Then
ExitWhenFound:
On Error GoTo 0
GoTo NormalExit
End If
On Error Resume Next 'avoid access permission errors.
For Each objSubFolder In objFolder.subfolders
If Err.Number = 0 Then
GetSubDirectories (objFolder.Path & "\" & objSubFolder.Name) 'recursive call.
Else
Err.Clear
End If
If gblStrPathAndFile <> "" Then GoTo ExitWhenFound 'safeguard.
Next objSubFolder
NormalExit:
End Sub
Sub GetFiles(strPath As String)
Dim objFile As Object, objFileSystem As Object, objFolder As Object
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFileSystem.GetFolder(strPath)
On Error Resume Next 'avoid access permission errors.
For Each objFile In objFolder.Files
If Err.Number = 0 Then
If objFile.Name = gblStrFileToFind Then
gblStrPathAndFile = strPath & "\" & gblStrFileToFind
Exit For
End If
Else
Err.Clear
End If
Next objFile
DoEvents
End Sub
thank you.