Copy or Move files from Excel to folder

[pgujju143]

below macro working for copy paste images to excel cell name to folder using path but this is only work single folder i need subfolder as well
Any budy help me for resolve this.

Thank in advance


Dim aryFolders() As Variant
Dim intFlexibleFolders As Long


Sub InstanciateFolders()
'Set up the array to be used. Place the default location as the first location
intFlexibleFolders = 2
ReDim aryFolders(1 To 2)
aryFolders(1) = "\\10.0.3.10\Images\GILI\Group_Brand_MIX"
End Sub
Sub BuildFolders()
Dim objFSO As Object
Dim objFolder As Object
Dim objSubFolder As Object
Dim i As Integer, strHoldMe As String
Call InstanciateFolders
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("\\10.0.3.10\Images\GILI\Group_Brand_MIX")
i = 1
'loops through each file in the directory and prints their names and path
For Each objSubFolder In objFolder.subfolders
ReDim Preserve aryFolders(1 To intFlexibleFolders)
strHoldMe = objSubFolder.Path
aryFolders(intFlexibleFolders) = strHoldMe
intFlexibleFolders = intFlexibleFolders + 1
Next objSubFolder
End Sub
Private Sub InsertImage_Click()
On Error Resume Next
Dim strFilePath As String, strFilePathandName As String, rngFileNameSource As Range
Dim Shp As Shape
Dim rngPicture As Range
Dim rngCell As Range, strDirectoryName As String
Call BuildFolders
For i = 1 To UBound(aryFolders)
strFilePath = aryFolders(i) & "\"
Set rngFileNameSource = Range("B2", Cells(Rows.Count, "B").End(xlUp))
'Loop through range of file names to get the name of the file
For Each rngCell In rngFileNameSource
'Set the full file name and path
'Add .jpg extenstion if missing
If Left(rngCell.Value, 4) <> ".jpg" Then
strFilePathandName = strFilePath & rngCell.Value & ".jpg"
Else
strFilePathandName = strFilePath & rngCell.Value
End If
'Load the directory of the file
strDirectoryName = Dir(strFilePathandName)
'If file is in directory then move picture into file
If strDirectoryName <> "" Then
Set rngPicture = rngCell.Offset(1, 0)
Set Shp = ActiveSheet.Shapes.AddPicture(Filename:=strFilePathandName _
, LinkToFile:=False, SaveWithDocument:=True, Left:=rngPicture.Left, Top:=rngPicture.Top _
, Width:=rngPicture.Width, Height:=rngPicture.Height)
Shp.Height = 100
If Shp.Height > 409 Then
rngCell.EntireRow.RowHeight = 409
Else
rngCell.EntireRow.RowHeight = Shp.Height
End If
Shp.Left = rngCell.Left
Shp.Top = rngCell.Top
End If
Next
DoEvents
Next
End Sub