Solved: Probably not the right tool but...can Excel..

[slang]

OK, I might be really pushing excel to do what it wasnt designed to do but here goes.:dunno

I have a folder that contains 6,000 jpeg files that need to copied to specific folders based on an Excel list.:rofl: :bug:

The list in Excel contains a two of information, Territory# (1-10) and location# (unique location number) every location is assigned to a territory.

The pictures are all named with the location# in the file name with two for each location.
Example, Location# 2343 would have two files, 2343-1.jpeg and 2343-2.jpeg

What I would like to happen is that for every location# in the list the code would look for the pictures in the folder and if they were there, copy them to the correct folder number. (each territory would have a folder to copy the pictures into.)

Kind of like if file "Location#"-1.jpeg exists then copy to c:\"territory#" if not next location in list. :rofl:

I know, NUTS!!!

Before we even start looking at this, can it be done?

Excel can do some wild things but Im not sure this is possible??

Anyone up for a challenge or a suggested approach?: pray2:

Thanks again
</IMG></IMG></IMG></IMG>

[mdmackillop]

Not too difficult. Can you post your Excel file?

[arkusM]

Oh it is possible that is for sure cause I have doen something like that before. Search the KB for this that is where I got code to do this. One for the entry that I found useful is HERE (http://vbaexpress.com/kb/getarticle.php?kb_id=827). The code will have to be tweaked.

Good luck.

M

EDIT: As usual to slow!! LOL this board can be so darn fast!! :bug:
EDIT2: I stepped into a ring with giants!! I will sit back and be amazed!! Good luck slang

[Bob Phillips]

Can you post a file example, just a few files in the list?

[slang]

2329

WOW!
Here is a cut of data for the list.

[slang]

2330
Here is a small picture

[Bob Phillips]

Public Sub PreocessData()
Dim FSO As Object
Dim FSOfldr As Object
Dim FSOfile As Object
Dim folder As String
Dim LastRow As Long
Dim i As Long

Set FSO = CreateObject("Scripting.FilesystemObject")

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 10 To LastRow

folder = "C:\" & .Cells(i, "A").Value
Set FSOfldr = Nothing
On Error Resume Next
Set FSOfldr = FSO.getfolder(folder)
On Error GoTo 0
If FSOfldr Is Nothing Then

For Each FSOfile In FSOfldr.Files

If Right$(FSOfile.Name, 3) = "JPG" Then

Name FSOfile As "C:\" & .Cells(i, "D").Value & "\" & FSOfile.Name
End If
Next FSOfile
End If
Next
End With
End Sub

[slang]

Arkusm, the code you refere to comes up with an error "user defined type not defined"

I like the flexability in that code but I am having difficulty in getting it to run.
''MUST set reference to Windows Script Host Object Model in the project using this code!
Option Explicit
Sub Copy_Files_To_New_Folder()
Dim fso As Object, objFSO As Object, objFolder As Object, PathExists As Boolean
Dim objFile As Object, strSourceFolder As String, strDestFolder As String
Dim x As String, Counter As Integer, Overwrite As String, i As Long, location As Integer, terr As Integer, lastrow As Integer
Set fso = CreateObject("Scripting.FilesystemObject")
Set objFSO = CreateObject("Scripting.FilesystemObject")
Set objFolder = CreateObject("Scripting.FilesystemObject")
Set objFile = CreateObject("Scripting.FilesystemObject")

Application.ScreenUpdating = False
Application.EnableEvents = False
strSourceFolder = "C:\All Retailers" 'Source path where all the files are located



With ActiveSheet
Counter = 0 'set the counter at zero for counting files copied
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row 'from xld to count how many locations there are
For i = 2 To lastrow
terr = .Cells(i, "P").Value 'gets the territory value for the location
strDestFolder = "C:\All Retailers\" & terr ' sets the destination folder to the right territory

'verify that the destination path exists, or it will create it:
On Error Resume Next
x = GetAttr(strDestFolder) And 0
If Err = 0 Then
PathExists = True
Else: PathExists = False
End If
If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one

On Error GoTo ErrHandler
Set objFSO = New FileSystemObject 'creates a new File System Object reference
Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder


For Each objFile In objFolder.Files 'for every file in the folder...
If InStr(1, objFile.Name, location & "-1.jpg") Then 'if the file name matches the location number and -1.jpg
objFile.Copy strDestFolder & "\" & objFile.Name ' there are two for each location -1 and -2
End If
If InStr(1, objFile.Name, location & "-2.jpg") Then 'if the file name matches the location number and -2.jpg
objFile.Copy strDestFolder & "\" & objFile.Name
End If
Counter = Counter + 1 'increment a count of files copied
Next objFile 'go to the next file
Next i

Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Exit Sub

NoFiles:
'Message to alert if Source folder has no files in it to copy
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on

Exit Sub 'exit sub here to avoid subsequent actions

ErrHandler:
'A general error message
MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
"Please verify that all files in the folder are not currently open," & _
"and the source directory is available"

Err.Clear 'clear the error
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
End With
End Sub

[arkusM]

Did you set the reference to Windows Script Host Object Model?
under tools Tools:Reference? I think the original code

I liked the flexiablity of the code as well. I copied you code and ran it w/out error, of course it *do* anything but no ref errors

Since you are trying to use it I will repost the code but it can also be found in the KB found HERE (http://vbaexpress.com/kb/getarticle.php?kb_id=827). (for proper credit (thx XLGibbs (http://www.vbaexpress.com/forum/member.php?u=4148)) and future reference) The code below is not the original code, I have made modifications for my own purposes...



Sub Copy_and_Rename_To_New_Folder()
''MUST set reference to Windows Script Host Object Model in the project using this code!
'This procedure will copy all files in a folder, and insert the last modified date into the file name'
'it is identical to the other procedure with the exception of the renaming...
'In this example, the renaming has utilized the files Last Modified date to "tag" the copied file.
'This is very useful in quickly archiving and storing daily batch files that come through with the same name on
'a daily basis. Note: All files in current folder will be copied this way unless condition testing applied as in prior example.
Dim objFSO As New Scripting.FileSystemObject, objFolder As Scripting.folder, PathExists As Boolean
Dim objFile As Scripting.File, strSourceFolder As String, strDestFolder As String
Dim x, Counter As Integer, Overwrite As String, strNewFileName As String
Dim strName As String, strMid As String, strExt As String
Dim sSavePath3 As String
Application.ScreenUpdating = False 'turn screenupdating off
Application.EnableEvents = False 'turn events off
'Call Show_BrowseDirectory_Dialog ' Allows the Dynmaic selection of Save Path
'identify path names below:
strSourceFolder = "C:\Test" 'Source path
'strDestFolder = "C:\Test\Destination" 'destination path, does not have to exist prior to execution
''''''''''NOTE: Path names can be strings built in code, cell references, or user form text box strings''''''
''''''''''example: strSourceFolder = Range("A1")
'below will verify that the specified destination path exists, or it will create it:
On Error Resume Next
x = GetAttr(strDestFolder) And 0
If Err = 0 Then 'if there is no error, continue below
PathExists = True 'if there is no error, set flag to TRUE
Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
"Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
'message to alert that you may overwrite files of the same name since folder exists
If Overwrite <> vbYes Then Exit Sub 'if the user clicks YES, then exit the routine..
'Else: 'if path does NOT exist, do the next steps
' PathExists = False 'set flag at false
' If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one
End If 'end the conditional testing
On Error GoTo ErrHandler
Set objFSO = CreateObject("Scripting.FileSystemObject") 'creates a new File System Object reference
Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder
Counter = 0 'set the counter at zero for counting files copied
If Not objFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section
For Each objFile In objFolder.Files 'for every file in the folder...
'parse the name in three pieces, file name middle and extension.
strName = Left(objFile.Name, Len(objFile.Name) - 4) 'remove extension and leave name only
'strMid = Format(objFile.DateLastModified, "_mmm_dd_yy") 'insert and format files date modified into name
'strMid = Format(Now(),"_mmm_dd_yy") 'sample of formatting the current date into the file name
strExt = Right(objFile.Name, 4) 'the original file extension
' For Valeo Daily
Dim strDate As String
'strDate = Right(strName, 8)
'strNewFileName = Mid(strDate, 3, 2) & "-" & Mid(strDate, 5, 2) & "-" & Mid(strDate, 7, 2) & " elec Valeo " & _
Left(strName, Len(strName) - 9) & strExt 'build the string file name (can be done below as well)
' End Valeo Daily
'strNewFileName = strName & " TET" & strExt
strNewFileName = "09 lqd " & strName & " TRS" & strExt
'objFile.Copy strDestFolder & "\" & strNewFileName 'copy the file with NEW name!
objFile.Name = strNewFileName '<====this can be used to JUST RENAME, and not copy
'The below line can be uncommented to MOVE the files AND rename between folders, without copying
'objFile.Move strDestFolder & "\" & strNewFileName

'End If 'where conditional check, if applicable would be placed.
' Uncomment the If...End If Conditional as needed
Counter = Counter + 1
Next objFile 'go to the next file
'MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
" copied/moved to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!"
'Message to user confirming completion
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Exit Sub
NoFiles:
'Message to alert if Source folder has no files in it to copy
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
Exit Sub 'exit sub here to avoid subsequent actions
ErrHandler:
'A general error message
MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
"Please verify that all files in the folder are not currently open," & _
"and the source directory is available"
Err.Clear 'clear the error
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
End Sub
Sub FolderExists()
Dim FSO
Dim folder As String
folder = "G:\Marketing\Market Price Guides\1Valeo Power Summaries"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(folder) Then
MsgBox folder & " is a valid folder/path.", vbInformation, "Path Exists"
Else
MsgBox folder & " is NOT a valid folder/path. ", vbInformation, " Invalid Path"
End If
End Sub

[slang]

Oh, cool.
I forgot about the reference tab. DUH.....:mkay

For Each objFile In objFolder.Files 'for every file in the folder...
If objFile = (location & "-1.jpg") Then 'if the file name matches the location number and -1.jpg
objFile.Copy strDestFolder & "\" & objFile.Name ' there are two for each location -1 and -2
End If
One more thing, when the code is ran the objfile.copy command -
objFile.Copy strDestFolder & "\" & objFile.Name
has the correct value except there is a : in the file name.
Example 101-1:.jpg
Any ideas?:dunno

I love VBA and what it can do, (support center doesn't!:devil2: ) and I wish I could spend more time developing so I could get better at it.

Thanks again....

[slang]

Bump, I edited my last post.
sorry....

[arkusM]

Oh, cool.
I forgot about the reference tab. DUH.....:mkay

For Each objFile In objFolder.Files 'for every file in the folder...
If objFile = (location & "-1.jpg") Then 'if the file name matches the location number and -1.jpg
objFile.Copy strDestFolder & "\" & objFile.Name ' there are two for each location -1 and -2
End If
One more thing, when the code is ran the objfile.copy command -
objFile.Copy strDestFolder & "\" & objFile.Name
has the correct value except there is a : in the file name.
Example 101-1:.jpg
Any ideas?:dunno

I love VBA and what it can do, (support center doesn't!:devil2: ) and I wish I could spend more time developing so I could get better at it.

Thanks again....

I am not sure... I am a bit of a hack at this... LOL

[Bob Phillips]

One more thing, when the code is ran the objfile.copy command -
objFile.Copy strDestFolder & "\" & objFile.Name
has the correct value except there is a : in the file name.
Example 101-1:.jpg
Any ideas?:dunno

I love VBA and what it can do, (support center doesn't!:devil2: ) and I wish I could spend more time developing so I could get better at it.


I don't get a : here.

[tpoynton]

Which code are you using? the code in post 8 never sets 'location'. I dont think that's the problem, but it makes me think the code you are using is different.

[slang]

Ok, got that fixed but now i get a error60verflow error.:banghead:

It looked too good to be true:(

Here is the mess i have now

Sub Copy_Files_To_New_Folder()
Dim objFSO As FileSystemObject, objFolder As folder, PathExists As Boolean
Dim objFile As File, strSourceFolder As String, strDestFolder As String
Dim x, Counter As Integer, Overwrite As String, i As Long, location As Integer, terr As Integer, lastrow As Integer

Application.ScreenUpdating = False
Application.EnableEvents = False
strSourceFolder = "C:\All Retailers" 'Source path where all the files are located



With ActiveSheet
Counter = 0 'set the counter at zero for counting files copied
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row 'from xld to count how many locations there are
For i = 2 To lastrow
terr = .Cells(i, "P").Value 'gets the territory value for the location
strDestFolder = "C:\" & terr ' sets the destination folder to the right territory
location = .Cells(i, "A").Value
'verify that the destination path exists, or it will create it:
On Error Resume Next
x = GetAttr(strDestFolder) And 0
If Err = 0 Then
PathExists = True
Else: PathExists = False
End If
If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one

On Error GoTo ErrHandler
Set objFSO = New FileSystemObject 'creates a new File System Object reference
Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder


For Each objFile In objFolder.Files 'for every file in the folder...
Overwrite = (location & "-1.jpg")
If objFile.Name = Overwrite Then 'if the file name matches the location number and -2.jpg
objFile.Move strDestFolder & objFile.Name

End If
If objFile.Name = (location & "-2.jpg") Then 'if the file name matches the location number and -2.jpg
objFile.Move strDestFolder & "\" & objFile.Name
End If

Counter = Counter + 1 'increment a count of files copied
Next objFile 'go to the next file
Next i

Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Exit Sub

NoFiles:
'Message to alert if Source folder has no files in it to copy
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on

Exit Sub 'exit sub here to avoid subsequent actions

ErrHandler:
'A general error message
MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
"Please verify that all files in the folder are not currently open," & _
"and the source directory is available"

Err.Clear 'clear the error
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
End With
End Sub

I am going home to sleep on it:think:

[mdmackillop]

Try taking this out of the loop

Set objFSO = New FileSystemObject

[slang]

Once again mdmackillop, my ticking timebomb lives! LOL

Thanks as always...