Hello There,
I have been trying to move over 300+ pdf files to subfolders, which partially match filenames. The file names format is as follow:
Definition, PN 123456, SN unique
Definition(may change), PN 657634(may change), SN unique(always different)
Their pattern is Two Commas following by PN and SN: ..., PN ..., SN ...
The folder names are: PN 123456 SN unique.
The example:
filenames
folder names
The folders are subdirectories, second level.
I tried the information that, was kindly provided by @BNR bnr.455560 here
The below code run as Macro - does nothing.
I have been trying to move over 300+ pdf files to subfolders, which partially match filenames. The file names format is as follow:
Definition, PN 123456, SN unique
Definition(may change), PN 657634(may change), SN unique(always different)
Their pattern is Two Commas following by PN and SN: ..., PN ..., SN ...
The folder names are: PN 123456 SN unique.
The example:
filenames
| VALVE AFT SAFETY, PN 81155B010101, SN 00515 |
| CABIN PRESSURIZATION MODULE, PN 92147A020103, SN 00501 |
| AIR CYCLE MACHINE, PN 820906-3, SN 2010010011 |
| AIR CYCLE MACHINE, PN 820906-3, SN 2010010014 |
| TEMP REDUCTION SWITCH, PN 820907-2, SN 0414 |
folder names
| PN 81155B010101 SN 00515 |
| PN 92147A020103 SN 00501 |
| PN 820906-3 SN 2010010011 |
| PN 820906-3 SN 2010010014 |
| PN 820907-2 SN 0414 |
The folders are subdirectories, second level.
I tried the information that, was kindly provided by @BNR bnr.455560 here
The below code run as Macro - does nothing.
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 "Definition, PN 123456, SN unique.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 "Definition"
' element 2 in the array will hold "SN inique.pdf
Splitter = Split(FileName, ", ", 2)
' 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) holds the value "PN 123456, SN unique.pdf"
' split out the ".pdf" or whatever file extention
Splitter = Split(Splitter(1), ".")
' element (0) now just holds "PN 123456, SN unique" - this *SHOULD* be the sub directory or deal #
'Remove comma "," by replace it to ""
Splitter = Replace(Splitter(0), ",", "")
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
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 & "*.pdf"
' 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
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
Sub Sort_files_2_folders_()
End Sub
