Solved: Copying files to specific folders, determined by file prefix

[starsky]

Hi,

I produce over 50 MI packs on a monthly basis. These need to be stored in 17 folders, based on directorate. Each pack has its own 3 letter prefix that will be used to determine which folder it should go into. I've messed around with CopyFile code I've found, but can't figure out the code that will use the prefix to copy a particular file to a particular folder.

Any ideas?

Thanks.

[p45cal]

Have you got any code at all?

[Kenneth Hobs]

Please give examples.

e.g.
1. Copy c:\Invoice\KenInvoice123.xls to c:\Invoice\Ken\KenInvoice.xls.
2. C:\Invoice\Ken will always exists or not?
3. If c:\Invoice\Ken\KenInvoice.xls exists, overwrite it.

[starsky]

Destination folders will be constant and empty when the code is run.

So ideally the code will copy files AAA, BBB, CCC to Folder1; DDD, EEE, FFF to Folder2, etc.

p45 - this is the basic code I've been working with, though it is butchered and skeletal in this form. Copying all files to a single destination is fine, allocating groups of files to specific destination is the aim.


Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String

FromPath = SFdr 'a Constant
ToPath = MstFdr 'a Constant

FileExt = "*.xls"

If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If

FNames = Dir(FromPath & FileExt)

If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If


Set FSO = CreateObject("scripting.filesystemobject")
' FSO.CreateFolder (ToPath)
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath

[starsky]

Further clarity - Single source folder, but many destination folders.

[GTO]

Just a simple example, you would probably want to supply the sub/function with an array of desired prefacing codes and the applicable folder destination.


Option Explicit

Sub exa()
Dim FSO As Object '<FileSystemObject
Dim aryPreface As Variant
Dim i As Long

Const PATH_START As String = "G:\2010\_Tmp\2010-09-17\"

Set FSO = CreateObject("Scripting.FileSystemObject")

aryPreface = Array("vba", "Sea", "exa")
For i = 0 To 2
If Not FSO.FolderExists(PATH_START & aryPreface(i)) Then
FSO.CreateFolder (PATH_START & aryPreface(i))
End If

FSO.CopyFile PATH_START & aryPreface(i) & "?*.xls", _
PATH_START & aryPreface(i) & "\", False
Next
End Sub

[starsky]

Thanks GTO. A few queries :)

For i = 0 to 2, what does this line do?

Does the 'If...Then...Not' statement create a folder based on the file prefix that will then act as the destination folder? Destination folders will exist, but will not share names with the files being sent to them.

I can imagine arrays as part of the solution.

E.g. Code loops through all files in source folder and if a file name prefix is in Array("AAA","BBB","CCC") the file will be copied to Folder1, if file name prefix is in Array ("DDD",EEE","FFF") it will be copied to Folder2, etc.

I've some awareness of different pieces of code/syntax that will do different jobs, but I'm at the limit of my knowledge when it comes to combining them (if possible) or developing something more elegant.

I hope I make sense. Thanks again.

[vzachin]

i have something like this. there are better methods...


option explicit
Sub SaveToFolder()
Dim Wbk As Workbook
Dim Wb1 As String
Dim WbName As String
Dim UserNm As String
Dim FileDir As String
Dim FolderName As String
Wb1 = ThisWorkbook.Name
UserNm = Environ("USERNAME")

For Each Wbk In Workbooks

WbName = Mid(UCase(Wbk.Name), 1, 3)

Select Case WbName

Case Is = "AAA": FolderName = "Folder1"
Case Is = "BBB": FolderName = "Folder2"
Case Is = "CCC": FolderName = "Folder3"
Case Is = "DDD": FolderName = "Folder4"
Case Is = "EEE": FolderName = "Folder5"

Case Else
GoTo NextFile

End Select

On Error Resume Next
FileDir = "C:\Documents and Settings\" + UserNm + "\desktop\" & FolderName
MkDir FileDir

Application.DisplayAlerts = False
Wbk.SaveAs FileDir & "\" & WbName
Wbk.Close


NextFile:
Next

Application.DisplayAlerts = True

End Sub

[Kenneth Hobs]

I am not sure what 50 MI packs mean. I suppose that pack means file?

If you are going to automate processing of all files in a parent folder, you need to define what folder the prefix names go with. The Case method as demonstrated will work fine.

With a bit of work, the method that I posted in this link can be used. In that method, I let the user pick what files to copy. http://www.vbaexpress.com/forum/showthread.php?t=33738

[GTO]

Here is the code, ratehr heavily commented. I think this will answer your questions reference my example snippet.


Option Explicit

Sub exa()
Dim FSO As Object '<FileSystemObject
Dim aryPreface As Variant
Dim i As Long

'// Here would be the common/single folder that all the files are being copied or moved //
'// from. //
Const PATH_START As String = "D:\2010\_Tmp\2010-09-17\"

'// Created a reference to FileSystemObject; see vba help. //
Set FSO = CreateObject("Scripting.FileSystemObject")

'// Here, I simply used a demonstration of an array of 'filename prefixes'. In the //
'// folder I opened, I had a few wb's each, that started w/one of the below, hence, //
'// an easy test. //
'// As I mentioned, I would probably just use a two-dimensional array, one half //
'// would have the prefixes, and the second element in the same row/col could have //
'// the destination path. If destinations and/or prefixes might change later, we //
'// could pick up both from a spreadsheet. //
'// Back to our example: For my ease, I just chose to check if a folder with the //
'// same name as the prefix existed, if not create it. //
aryPreface = Array("vba", "Sea", "exa")

'// As mentioined, this defines a loop. 0 to 2 matches the elements in the array //
'// aryPreface, as we created a zero-based one-dimension array by using, (you guessed//
'// it) Array(). //
'// For absolute assuredness, we could use L/U Bound //
For i = LBound(aryPreface, 1) To UBound(aryPreface, 1)
If Not FSO.FolderExists(PATH_START & aryPreface(i)) Then
FSO.CreateFolder (PATH_START & aryPreface(i))
End If

'// You mentioned looping, and we are, but not once per file. We are only //
'// looping once per prefix. So, in our example, in the first time thru the //
'// loop, we are copying any/all files that start with "vba", followed by //
'// one-to-many characters, and ending with ".xls". //
'// Think of this as the same as when (in Windows Explorer) you click on one //
'// file, and with Shift pressed, click on another file so that several files //
'// are selected. Then you would copy them all at once. //
FSO.CopyFile PATH_START & aryPreface(i) & "?*.xls", _
PATH_START & aryPreface(i) & "\", False
Next
End Sub

Hope that helps,

Mark

[starsky]

Thanks for your help guys, I'll look at these this morning, I think these will all increase my knowledge base.

Kenneth - MI packs - management information packs. Basically an excel file composed of numerous reports.

Thanks again, I really appreciate your effort.

[Kenneth Hobs]

If you use this code add the reference, modify the function for your subfolder names and prefixes, and change the parent folder name if needed.

Notice that if no prefix is set in a Case in the function, then NA is returned. An IF in the Sub tells it to skip NA's.

Sub fsoCopyFiles()
Rem Needs Reference: MicroSoft Scripting Runtime, scrrun.dll
Rem Instructions: http://support.microsoft.com/default.aspx?scid=kb;en-us;186118
Dim FSO As New FileSystemObject
Dim fs As Files, f As file
Dim pFolder As String, sFolder As String

'Parent folder name.
pFolder = ThisWorkbook.Path & "\"

With FSO
'Exit if parent folder does not exist.
If Not .FolderExists(pFolder) Then
MsgBox pFolder & " does not exist.", vbCritical, "Macro Ending"
Exit Sub
End If

'Interate through the files in the parent folder.
Set fs = .GetFolder(ThisWorkbook.Path).Files
For Each f In fs
sFolder = GetSubFolderByPrefix(.GetBaseName(f))
If sFolder = "NA" Then GoTo Nextf
'Create the subfolder if needed.
sFolder = pFolder & sFolder & "\"
If Not .FolderExists(sFolder) Then .CreateFolder sFolder
'Copy the files from the parent folder to the subfolder if not this workbook.
If ThisWorkbook.FullName <> f Then .CopyFile f, sFolder & .GetFileName(f), True 'True overwrite.
Nextf:
Next f
End With

'Cleanup
Set f = Nothing
Set fs = Nothing
Set FSO = Nothing
End Sub

Function GetSubFolderByPrefix(baseFilenameWithPrefix As String) As String
Select Case UCase(Left(baseFilenameWithPrefix, 3))
Case Is = "AAA": GetSubFolderByPrefix = "Folder1"
Case Is = "BBB": GetSubFolderByPrefix = "Folder2"
Case Is = "CCC": GetSubFolderByPrefix = "Folder3"
Case Is = "DDD": GetSubFolderByPrefix = "Folder4"
Case Is = "EEE": GetSubFolderByPrefix = "Folder5"
Case Is = "FIL": GetSubFolderByPrefix = "File"
Case Is = "FOL": GetSubFolderByPrefix = "Folder"
Case Else: GetSubFolderByPrefix = "NA"
End Select
End Function

[starsky]

Thanks Kenneth, and everyone.

I just actually managed to cobble a mixture of a loop through all xl files in folder x with case select and an array. It works perfectly but could no doubt be more elegant.

I am going to look at all methods here in order to learn. Many thanks.