使用VBA按文件名部分匹配将PDF文件移动至对应子文件夹

问题描述 #

需批量移动300+PDF文件至对应二级子文件夹，规则如下：

• 文件名格式：[描述], PN [编号], SN [唯一编号].pdf（描述、PN编号可变，SN编号唯一，整体含两个逗号分隔）
• 目标子文件夹命名：提取文件名中PN [编号], SN [唯一编号]部分，替换逗号为空格，即PN [编号] SN [唯一编号]

示例：
文件名：

VALVE AFT SAFETY, PN 81155B010101, SN 00515.pdf
CABIN PRESSURIZATION MODULE, PN 92147A020103, SN 00501.pdf
AIR CYCLE MACHINE, PN 820906-3, SN 2010010011.pdf

对应目标文件夹：

PN 81155B010101 SN 00515
PN 92147A020103 SN 00501
PN 820906-3 SN 2010010011

原参考VBA代码运行后无效果，代码如下：

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 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

原代码问题分析 #

1. 入口子过程Sort_files_2_folders_为空，未调用核心逻辑Check_Files，运行此宏不会执行任何操作。
2. Return_SubDirectory_Name函数逻辑错误：
   • 使用Split(FileName, ", ", 2)仅分割为2部分，无法正确提取PN和SN段；
   • 将Replace返回的字符串赋值给数组变量Splitter，导致类型不匹配，最终无法返回正确的文件夹名称。
3. Check_Files中路径拼接错误：File_Type = Search_Path & "*.pdf"缺少路径分隔符，会导致Dir无法识别正确的文件路径。
4. Confirm_Directory逻辑颠倒：仅当目录已存在时才尝试创建子目录，完全违背了创建目录的初衷。

修正后的完整代码 #

' 提取文件名中的PN和SN部分，生成目标文件夹名称
Public Function Return_SubDirectory_Name(FileName As String) As String
    Dim arrParts() As String
    Dim fileNameNoExt As String
    
    ' 先移除文件扩展名
    fileNameNoExt = Left(FileName, InStrRev(FileName, ".") - 1)
    
    ' 按", "分割文件名（不含扩展名），得到3个部分
    arrParts = Split(fileNameNoExt, ", ")
    
    ' 验证分割结果是否符合预期格式
    If UBound(arrParts) = 2 And Left(arrParts(1), 3) = "PN " And Left(arrParts(2), 3) = "SN " Then
        ' 拼接PN和SN部分，替换逗号为空格
        Return_SubDirectory_Name = arrParts(1) & " " & arrParts(2)
    Else
        Return_SubDirectory_Name = vbNullString
    End If
End Function

' 核心移动逻辑：遍历指定路径下的PDF文件，移动到对应子文件夹
Public Sub Check_Files(Search_Path 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
    
    ' 目标根目录设为当前工作簿所在路径
    Archive_Path = ThisWorkbook.Path
    ' 确保搜索路径末尾有路径分隔符
    If Right(Search_Path, 1) <> "\" Then Search_Path = Search_Path & "\"
    
    ' 遍历路径下所有PDF文件
    strFileName = Dir(Search_Path & "*.pdf")
    
    Do While Len(strFileName) > 0
        ' 获取目标文件夹名称
        Deal_Name = Return_SubDirectory_Name(strFileName)
        
        If Len(Deal_Name) > 0 Then
            ' 拼接目标文件夹完整路径
            Target_Path = Archive_Path & "\" & Deal_Name
            
            ' 确保目标文件夹存在，不存在则创建
            If Dir(Target_Path, vbDirectory) = vbNullString Then
                MkDir Target_Path
            End If
            
            ' 移动文件：复制后删除原文件
            FileCopy Search_Path & strFileName, Target_Path & "\" & strFileName
            Kill Search_Path & strFileName
            
            File_Count = File_Count + 1
        End If
        
        ' 获取下一个文件名
        strFileName = Dir
    Loop
    
    ' 输出移动结果到立即窗口
    Debug.Print "成功移动 " & File_Count & " 个文件"
End Sub

' 入口宏：修改此处的搜索路径为你的PDF文件所在路径
Sub Sort_files_2_folders_()
    ' 替换为你的PDF文件所在的实际路径，示例："C:\PDF_Files"
    Check_Files "C:\你的PDF文件所在路径"
End Sub

使用说明 #

1. 打开Excel，按Alt+F11打开VBA编辑器；
2. 插入模块，将修正后的代码粘贴进去；
3. 修改Sort_files_2_folders_子过程中的搜索路径为你的PDF文件实际所在路径；
4. 运行Sort_files_2_folders_宏即可开始批量移动文件。

内容的提问来源于stack exchange，提问作者Sam