Copy or Move files from Excel to folder

pgujju143

New Member
Joined
Mar 15, 2016
Messages
39
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
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,491
Messages
5,764,679
Members
425,229
Latest member
Rashid mahmood

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top