我一直在尝试将300多个pdf文件移到子文件夹中，这些文件与文件名部分匹配。文件名格式如下：
Definition, PN 123456, SN unique
Definition(may change), PN 657634(may change), SN unique(always different)
他们的模式是两个逗号，后面跟着PN和SN:。。。，PN。。。，SN。。。
文件夹名称为：PN 123456 SN unique。
示例：
文件名
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
文件夹名称
PN 81155B010101 SN 00515
PN 92147A020103 SN 00501
PN 820906-3 SN 2010010011
PN 820906-3 SN 2010010014
PN 820907-2 SN 0414
文件夹是二级子目录。
我在这里尝试了@BNR BNR.455560善意提供的信息：https://www.mrexcel.com/board/threads/moving-files-to-a-subfolder-based-on-partial-filename-with-vba.1120135/
我的原始帖子：https://www.mrexcel.com/board/threads/moving-files-to-a-subfolder-based-on-partial-filename-with-vba.1221014/
下面的代码作为宏运行-不执行任何操作。
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:DesktopMyFiles" or something
Archive_Path = ThisWorkbook.Path
' the search_path is handed into the function as an argument
' 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
试试这个(根据需要调整文件路径(
Sub RelocateFiles()
Dim allFiles As Collection 'of File objects
Dim allFolders As Collection 'of Folder objects
Dim f As Object, fld As Object, sn As String, bMoved As Boolean
'find all files (include subfolders)
Set allFiles = GetFiles("C:TempTestFiles", "*.pdf", True)
'find all destination folders
Set allFolders = GetFolders("C:TempTestFiles", True)
For Each f In allFiles 'loop over files
sn = GetSN(f.Name) 'get SN part of name
bMoved = False 'reset flag
If Len(sn) > 0 Then 'has "sn" part ?
For Each fld In allFolders 'loop over folders
If GetSN(fld.Name) = sn Then 'check folder name
Debug.Print "Moving '" & f.Name & _
"' to '" & fld.Path & "'"
f.Move fld.Path & "" 'move the files
bMoved = True 'flag moved
Exit For 'stop checking
End If
Next fld
End If
If Not bMoved Then Debug.Print "## Not moved: " & f.Name
Next f
End Sub
'Return the "sn" part for a folder or file name
Function GetSN(txt As String) As String
Dim arr, sn, pos As Long
arr = Split(txt, " SN ")
If UBound(arr) > 0 Then
sn = arr(UBound(arr))
pos = InStr(sn, ".") 'any extension? (if a filename)
If pos > 0 Then sn = Left(sn, pos - 1) 'remove extension
GetSN = sn
End If
End Function
'Find all folders under `startFolder`
' Returns a collection of Folder objects
Function GetFolders(startFolder As String, _
Optional subFolders As Boolean = True) As Object
Dim fso, fldr, f, subFldr, fpath
Dim colFolders As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
For Each subFldr In fldr.subFolders
If subFolders Then colSub.Add subFldr.Path
colFolders.Add fso.getfolder(subFldr.Path)
Next subFldr
Loop
Set GetFolders = colFolders
End Function
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetFiles(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fpath
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.getfolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
fpath = fldr.Path
If Right(fpath, 1) <> "" Then fpath = fpath & ""
f = Dir(fpath & filePattern) 'Dir is faster...
Do While Len(f) > 0
colFiles.Add fso.getfile(fpath & f)
f = Dir()
Loop
Loop
Set GetFiles = colFiles
End Function