VBA Create folder and move file based on folder names in table

Question

I have around 10,000 files all in one folder called "Z:\ContactLog\". The files are named "Contact_1.pdf", "Contact_2.pdf" etc. I also have an Access table with the file names listed in the first column and an associated group name in the second column. The group names are "Group1", Group2" etc.

I need help to write the VBA code to create a sub-folder for each group using the group name as the folder name, (e.g. "Z:\ContactLog\Group1\") and then move the files into the folders according to the group names listed against the file names in the table.

My research so far has found code for moving files based on the file name, but not based on a table field entry. Any help to get started with writing the VBA would be greatly appreciated. I am using Access 2010, but will do this in Excel if needed. Thank you.

Answer 1

I hope it isn't considered bad form to answer your own question, but I have just thought of and tested an answer using a completely different approach.

To achieve the goal I did the following:

1. Export the access table to Excel, so column A has the file name and column B has the name of the desired destination folder.

2. In column C use the formula...

=CONCATENATE("xcopy Z:\ContactLog\",A1,".pdf Z:\ContactLog\",B1,"\ /C")

3. Copy the formula downwards for all 10,000 entries

4. Copy and paste column C into a batch file

5. Run the batch file

6. Manually delete the source files

I have tried this on a small sample of the entries and it works perfectly. Xcopy will create the folders that don't exist. The switch "/C" will allow the batch to continue if there is an error (e.g. if the file does not exist).

Answer 2

Looks like your set, but I thought I would add an Access answer for the heck of it.

First back up the entire folder in question so you can revert incase something goes wrong. Next add a column in the file information table called FILE_MOVED so you can use it as a flag.

I've done this sort of thing a lot and have run into many issues like files moved, renamed, locked, etc. (If there's an error in the run, you'll end up with more errors on subsequent runs trying to move file's that have already been moved.) Be sure to update the FILE_MOVED col to 0 or null if you have to revert to original folder. So here's some code that should accomplish what you wanted:

Declare this in a Module:

Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

Paste this into a Module:

Function OrganizeFiles() As Long
On Error GoTo ErrHandler
Dim rst As New ADODB.Recordset
Dim strFolderFrom As String, strFolderTo As String
Dim strPathFrom As String, strPathTo As String

rst.CursorLocation = adUseClient
rst.CursorType = adOpenForwardOnly
rst.LockType = adLockOptimistic

rst.Open "SELECT * FROM [YourTableName] WHERE nz(FILE_MOVED,0) = 0 ", CurrentProject.Connection

strFolderFrom = "Z:\ContactLog\" 'the main folder will always be the same
Do Until rst.EOF

'destination folder
strFolderTo = strFolderFrom & rst.Fields("[YourGroupCol]") & "\" 'destination folder can change

'make sure the destination folder is there; if not, then create it
If Dir(strFolderTo, vbDirectory) = "" Then MkDir strFolderTo

'get the source file path
strPathFrom = strBaseFolder & rst.Fields("[YourFileNameCol]")

'get the destination file path
strPathTo = strFolderTo & rst.Fields("[YourFileNameCol]")

Call MoveFile(strPathFrom, strPathTo)

'at this point the file should have been moved, so update the flag
rst.Fields("FILE_MOVED") = 1

rst.MoveNext
Loop

rst.Close

ErrHandler:
Set rst = Nothing
If err.Number <> 0 Then
MsgBox err.Description, vbExclamation, "Error " & err.Number
End If
End Function

This task and the my code is pretty basic but this kind of thing can become complicated when working with multiple source and destination folders or changing file names in addition to moving them.