Hi Booker,
There are several issues you need to address.
- Extract the correct subdirectory name or #deal from the file name
- Identify if the correct directory / file relationship (assuming your 01 - 567567, 02 - 567567 format always holds true)
- Confirm if the sub directory exists (if it doesn't then what happens?)
- If the directory exists AND the file is correctly identified, then move the file as required
Point 1
The following code accepts a file name as a string and returns the subdirectory name (based on your original post)
VBA Code:
Public Function Return_SubDirectory_Name(FileName As String) As String
'define a string array
Dim Splitter() As String
' check if we have a filename with a length > 0 - i.e. no empty filenames
If Len(FileName) > 0 Then
' let's assume the filename is "02 - 123456.pdf"
' Split creates a string array with the " - " as the break point - notice the space before and after the "-" character
' element 0 in the array will hold "02"
' element 1 in the array will hold "12345.pdf
Splitter = Split(FileName, " - ")
' test to make sure the array has JUST two elements
' 1st element of ANY array starts with zero
' logic would need to be adjusted if file name was something like "02 - 12345 - 123.pdf" - as plsit function would create more elements
If UBound(Splitter) = 1 Then
' now splitter (1) holes the value "123456.pdf"
' split out the ".pdf" or whatever file extention
Splitter = Split(Splitter(1), ".")
' element (0) now just holds "123456" - this *SHOULD* be the sub directory or deal #
Return_SubDirectory_Name = CStr(Splitter(0))
' now exit the function
Exit Function
End If
' if above logic didn't work (maybe weird file name or whatever) - then drop out here with vbnullstring (empty) filename
Return_SubDirectory_Name = vbNullString
End If
End Function
Points 2 / 4
The following code accepts a search path (something like "C:\Desktop\MyFiles").
It also uses a nominated archive path where you want the files saved AND the type of files (.msg or whatever) you're looking for.
It then makes a copy of the required file, saves it to the target archive file and finally deletes the original file
VBA Code:
Public Sub Check_Files(Search_Path As String)
Dim File_Name As String
Dim File_Type As String
Dim strFileName As String
Dim Deal_Name As String
Dim Archive_Path As String
Dim Target_Path As String
Dim File_Count As Integer
' setup where the archive directory is - maybe a network location?
' I'll assume it is the same directory path as the work book - change the following path as required
' path should be in a format like "C:\Desktop\MyFiles" or something
Archive_Path = ThisWorkbook.Path
' the search_path is handed into the function as an arguement
' checks the Search path - this path is where the file currently are - maybe different than where you want to archive them
Confirm_Directory Search_Path
' changes excel's default directory path to the one you want to search
ChDir Search_Path
' assumes .msg files, but could be .pdf files - make changes as needed
File_Type = Search_Path & "*.msg"
' identifies file name within the target directory
strFileName = Dir(File_Type)
' cycles through each file within the search directory - will continue until the length of the strFileName = 0 (i.e. no files)
Do While Len(strFileName) > 0
' get the sub directory or #deal name
Deal_Name = Return_SubDirectory_Name(strFileName)
' test if we have a valid deal name (not a vbnullstring)
If Len(Deal_Name) > 0 Then
' update the target_path - the target path will change as the different #deal name subdirectories within the archive path change
Target_Path = Archive_Path & "\" & Deal_Name
' checks if THAT target archive path exists - makes one if it doesn't
Confirm_Directory Target_Path
' copy required file to the target archive directory
FileCopy Search_Path & "\" & strFileName, Target_Path & "\" & strFileName
' delete original copy from search directory
Kill Search_Path & "\" & strFileName
File_Count = File_Count + 1
End If
' aquires the next filename in the search directory
strFileName = Dir
Loop
Debug.Print "Moved " & File_Count & " file(s)"
End Sub
Point 3
The following code will confirm if a directory exists and if it doesn't, it will create the required sub directory
VBA Code:
Public Sub Confirm_Directory(This_Path As String)
' used to test for directory locations
' will make sub directories if required
Dim Splitter() As String
Dim Test_Path As String
If Dir(This_Path, vbDirectory) <> vbNullString Then
Splitter = Split(This_Path, "\")
For I = LBound(Splitter) To UBound(Splitter)
If I = 0 Then
Test_Path = Splitter(0)
Else
Test_Path = Test_Path & "\" & Splitter(I)
End If
ReTest:
If Dir(Test_Path, vbDirectory) = vbNullString Then
'Debug.Print "'" & Test_Path & "' does not exist"
MkDir Test_Path
'Debug.Print "Making ' " & Test_Path & "'"
GoTo ReTest
Else
'Debug.Print "'" & Test_Path & "' exists"
End If
Next I
End If
End Sub
I would
HIGHLY RECOMMEND that you test this code out with some dummy data first to fully understand how it works before using it on real data.
Some people may not like the deletion aspect of the above codebase, I have used this myself for years, but if you understand when and how it operates you should not have any issues.
While this code does work, you should probably add further checking and error handling measures to ensure it executes the way you expect it to.
I don't know the full extent of the possible variations of directory paths, filenames etc and so this code doesn't account for unforeseen issues.
At the very least, I hope it gets you started along the path to automate this process (sorry but automatize isn't a real word
regards,
BenR
