VB Code to move image files into their asociated folders identified in an excel spreadsheet

jamjam123

New Member
Joined
May 4, 2018
Messages
3
I have an excel spreadsheet which identifies where image files need to be moved.
At the moment all the image files are located in one large folder on my external hard drive f:\
So, I want to move all the images that correspond to the folder name which is recorded in excel spreadhseet
I have 3,093 folders with approximately 6,000 images.

I don't know programming. I found the script below but it asks for a source and destination folder. I have manually gotten through 300 folders but it's taking ages.
Would anyone be able to help me do this in one F5 run

Folder Name File Name
301
43310.tif
302
26189.tif
302
37000.tif
303
43205.tif
304
25866.tif
304
32694.tif

<colgroup><col><col></colgroup><tbody>
</tbody>


Sub copyfiles()
'Updateby Extendoffice
Dim xRg As Range, xCell As Range
Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
Dim xSPathStr As Variant, xDPathStr As Variant
Dim xVal As String
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xSFileDlg.Title = "Please select the original folder:"
If xSFileDlg.Show <> -1 Then Exit Sub
xSPathStr = xSFileDlg.SelectedItems.Item(1) & ""
Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = "Please select the destination folder:"
If xDFileDlg.Show <> -1 Then Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) & ""
For Each xCell In xRg
xVal = xCell.Value
If TypeName(xVal) = "String" And xVal <> "" Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
End If
Next
End Sub
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Maybe something like:


Code:
Sub CopyEm()

Dim strFolderFrom As String
Dim strFolderTo As String
Dim strFileName As String
Dim rngStart As Range
Dim r As Long

Set rngStart = Range("A1")  ' starting cell with folder names
strFolderFrom = "C:\whatever\folder\you\have\"

r = 1   ' to start with first row below A1

Do While rngStart.Offset(r, 0) <> ""
    strFolderTo = rngStart.Offset(r, 0) & "\"  ' add last back slash
    strFileName = rngStart.Offset(r, 1)      ' file name in B column
    FileCopy strFolderFrom & strFileName, strFolderTo & strFileName
    r = r + 1
Loop
MsgBox "Done", vbExclamation
 
End Sub
 
Last edited:
Upvote 0
Thanks very much Pat,

I am getting Run-time error '53': File not found
When i debug it refers to line
FileCopy strFolderFrom & strFileName, strFolderTo & strFileName

I have entered strFolderFrom = F:\images

Am i missing something? Do i need to declare
FileCopy
FileCopy
 
Upvote 0
Try adding a backslash....


Code:
strFolderFrom = "F:\images\"

To see the final values of the folder/file names... before the FileCopy statement put in..

Code:
msgbox "From=" & strFolderFrom & strFileName & vbcrlf & "To=" & strFolderTo & strFileName

Then make sure that the from and to have the correct paths with slashes.
 
Last edited:
Upvote 0
HI Pat, many thanks for your help./ You're a legend...
Base don your feedback...

Sub CopyEm()

Dim strFolderFrom As String
Dim strFolderTo As String
Dim strFileName As String
Dim rngStart As Range
Dim r As Long

Set rngStart = Range("A1") ' starting cell with folder names
strFolderFrom = "F:\Images"

r = 1 ' to start with first row below A1

Do While rngStart.Offset(r, 0) <> ""
strFolderTo = "F:" & rngStart.Offset(r, 0) & "" ' add last back slash
strFileName = rngStart.Offset(r, 1) ' file name in B column
FileCopy strFolderFrom & strFileName, strFolderTo & strFileName
r = r + 1
Loop
MsgBox "Done", vbExclamation

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,504
Messages
6,114,016
Members
448,543
Latest member
MartinLarkin

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
Back
Top