PDA

View Full Version : Use cell value to search for a file & Copy/Paste?



YellowLabPro
04-29-2007, 09:59 AM
This was initially posted on Mrexcel.com-
http://www.mrexcel.com/board2/viewtopic.php?p=1300393#1300393

From within Excel can code do a compare of a file record number and perform a search using this record# for a file, if it finds the file,copy this file to another file folder? This would need to loop through every cell in "A" and copy all instances of this file which could have multiple instances, designated w/ an underscore and numeric instance, ******.jpg, ******_2.jpg, ******_3.jpg?

Example:
From within Excel- record# is in (A4) = ES1LASBRN
File folder containing images=
C:\Product_Images & contains files named: ES1LASBRN.jpg, ES1LASBRN_1.jpg, ES1LASBRN_2.jpg
Copy:
ES1LASBRN.jpg, ES1LASBRN_1.jpg, ES1LASBRN_2.jpg
Paste to:
C:\Upload_Images

Thanks,

YLP

mdmackillop
04-29-2007, 11:00 AM
Here's the basics, let us know if you need a hand with the loop.

Sub FindAndCopy()

'Set reference to MS Scripting Runtime
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile "G:\Test*.jpg", "G:\Image\"

End Sub

YellowLabPro
04-29-2007, 11:07 AM
Md,
Not sure here. From reading this, it appears the code copies from the root of G: a test.jpg file to a folder on G:\Image

Do you want me to test this, or is this the complete code?

YellowLabPro
04-29-2007, 11:13 AM
I just re-read your last post and saw you mentioned to ask if I needed help w/ the loop. Sorry, missed that part.

YellowLabPro
04-29-2007, 11:14 AM
Is there are reason you chose G: instead of C: ?

mdmackillop
04-29-2007, 12:07 PM
Here's a looping code
Re the G drive; it was just a quick setup to test. Change to your own locations
Sub FindAndCopy()
Di fs, cel as range
'Set reference to MS Scripting Runtime
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cel In Range(Cells(4, 1), Cells(Rows.Count, 1).End(xlUp))
fs.CopyFile "G:\" & cel & "*.jpg", "G:\Image\"
Next
End Sub

YellowLabPro
04-29-2007, 12:54 PM
Thanks MD,
I get an error telling me the file cannot be found.
I have placed the code in the module exactly as you provided except for the drive letter and folders.
I have not referenced the sheet/qualified the workbook nor sheet.
The worksheet that the loop is supposedly running on is open and active.

Here is the path as changed for my system:

fs.CopyFile "c:\Completed\" & cel & "*.jpg", "c:\Upload\"

On C: I have two folders, Completed and Upload
Completed contains the following files
CI1A50BWR.jpg
CI1A50BWR_1.jpg
CI1A50BWR_2.jpg
CI1A50BWS.jpg
CI1A50BWS_1.jpg
CI1A50BWS_2.jpg

Upload contains nothing.

My spreadsheet has these values beginning in A4, & A5 respectively.
CI1A50BWR
CI1A50BWS

YellowLabPro
04-29-2007, 01:09 PM
I have gone back and qualified the worksheet:


Sub FindAndCopy()
Dim fs, cel As Range
Dim Wba As Workbook
Dim Wsa As Worksheet

Set Wsa = ActiveWorkbook.Sheet1
'Set reference to MS Scripting Runtime
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cel In Range(Cells(4, 1), Cells(Rows.Count, 1).End(xlUp))
fs.CopyFile "c:\Completed\" & cel & "*.jpg", "c:\Upload\"
Next
End Sub

mdmackillop
04-29-2007, 01:51 PM
This works for me.
You created a variable WSA (syntax error corrected) but didn't actually use it. With the active sheet containing the data, it was not strictly necessary, but I've incorporated it below, so the code will run from any sheet.
Option Explicit
Sub FindAndCopy()
Dim fs, cel As Range
Dim Wba As Workbook
Dim Wsa As Worksheet

Set Wsa = ActiveWorkbook.Sheets(1)
'Set reference to MS Scripting Runtime
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cel In Range(Wsa.Cells(4, 1), Wsa.Cells(Rows.Count, 1).End(xlUp))
fs.CopyFile "c:\Completed\" & cel & "*.jpg", "c:\Upload\"
Next
End Sub

YellowLabPro
04-29-2007, 02:58 PM
MD,
I am unable to get it past the error;
Runtime error 53, cannot find file:

This the line where I get the error.
fs.CopyFile "C:\Completed\" & cel & "*.jpg", "C:\Upload\"

Sub FindAndCopy2()
Dim fs, cel As Range
Dim Wba As Workbook
Dim Wsa As Worksheet

Set Wsa = ActiveWorkbook.Sheets(1)
'Set reference to MS Scripting Runtime
Set fs = CreateObject("Scripting.FileSystemObject")
For Each cel In Range(Wsa.Cells(4, 1), Wsa.Cells(Rows.Count, 1).End(xlUp))
fs.CopyFile "C:\Completed\" & cel & "*.jpg", "C:\Upload\"
Next
End Sub

Just to double check myself, I did a search on my machine, limited to C: and it found the files in the C:\Completed Directory.
I am uploading a .pdf that contains a screenshot of the search and the worksheet.

If you are successful, then how or where do I begin to troubleshoot failure on my end?

YellowLabPro
04-29-2007, 03:32 PM
MD,
I think I have found the problem, if there are values in the sheet and do not have a corresponding file in the folder, it cannot find the file.
From the limited amount of error trapping I am familiar w/, I believe the addition of this will solve.
I will work on this.
Thanks for help here....

YLP

mdmackillop
04-29-2007, 04:00 PM
I'd assumed that all entries would have corresponding files. You could test using the Dir function or check out FileSearch Object in VBA help

YellowLabPro
04-29-2007, 05:44 PM
MD,
I should have been more clear. I have just reviewed the Dir Function and FileSearch object. I cannot at this point determine how to incorporate either one of them into your procedure.

The spreadsheet and image folder(s) need to be searched, matched, and migrated to the one folder. You have accomplished the first part of this for me.

(Might be superfluous at this point)
The worksheet will always have item records that will not have images. This is due to the fact that certain items have a master record number, and the images are assigned to these records. The other item record numbers are the sizes of these master records. The code needs to skip these records, the way I understand it to handle this would be to On Error Resume.
My attempt at adding Error Trapping breaks at End If.

Here is my initial attempt at adding Error Handling. I have read Johnske's article on error handling, but I do not have enough experience w/ it yet to write a successul procedure.

Option Explicit
Sub FindAndCopy2()
Dim fs, cel As Range
Dim Wba As Workbook
Dim Wsa As Worksheet
Dim iStatus As Long
Err.Clear
On Error Resume Next
Set Wsa = ActiveWorkbook.Sheets(1)
iStatus = Err
'Set reference to MS Scripting Runtime
Set fs = CreateObject("Scripting.FileSystemObject")
On Error GoTo 0
If iStatus Then
For Each cel In Range(Wsa.Cells(4, 1), Wsa.Cells(Rows.Count, 1).End(xlUp))
fs.CopyFile "C:\Completed\" & cel & "*.jpg", "C:\Upload\"
End If
Next
End Sub

mdmackillop
04-30-2007, 11:10 AM
You could use error handling as follows
Sub FindAndCopy2()
Dim fs, cel As Range
Dim Wba As Workbook
Dim Wsa As Worksheet

On Error Resume Next

Set Wsa = ActiveWorkbook.Sheets(1)
Set fs = CreateObject("Scripting.FileSystemObject")

For Each cel In Range(Wsa.Cells(4, 1), Wsa.Cells(Rows.Count, 1).End(xlUp))
fs.CopyFile "C:\Completed\" & cel & "*.jpg", "C:\Upload\"
Next
End Sub

I think it better practice to determine if the files exist, then copy them
Sub FindAndCopy()
Dim fs, cel As Range
Dim Wba As Workbook
Dim Wsa As Worksheet

Set Wsa = ActiveWorkbook.Sheets(1)
Set fs = CreateObject("Scripting.FileSystemObject")

For Each cel In Range(Wsa.Cells(4, 1), Wsa.Cells(Rows.Count, 1).End(xlUp))
With Application.FileSearch
.NewSearch
.LookIn = "C:\Completed"
.Filename = cel
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
fs.CopyFile "c:\Completed\" & cel & "*.jpg", "c:\Upload\"
Else
msg = msg & cel & vbCr
End If
End With
Next
MsgBox "There were no files found called" & vbCr & msg
End Sub