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

[jamjam123]

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
[TABLE="width: 192"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]301
[/TD]
[TD] 43310.tif
[/TD]
[/TR]
[TR]
[TD]302
[/TD]
[TD] 26189.tif
[/TD]
[/TR]
[TR]
[TD]302
[/TD]
[TD] 37000.tif
[/TD]
[/TR]
[TR]
[TD]303
[/TD]
[TD] 43205.tif
[/TD]
[/TR]
[TR]
[TD]304
[/TD]
[TD] 25866.tif
[/TD]
[/TR]
[TR]
[TD]304
[/TD]
[TD] 32694.tif
[/TD]
[/TR]
</tbody>[/TABLE]


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

 

[PatOBrien198]

Maybe something like:

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

 

[jamjam123]

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

 

[PatOBrien198]

Try adding a backslash....

strFolderFrom = "F:\images\"

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

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

Then make sure that the from and to have the correct paths with slashes.

 

[jamjam123]

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