基于RegEx与Excel VBA的文件名日期提取及重命名问题

需求说明：需将格式为「FirstName SURNAME_dmmyy.pdf」或「FirstName SURNAME_ddmmyy.pdf」的PDF文件名，重命名为「FirstName SURNAME_yyyymmdd.pdf」（月份固定为两位，日期可为1位或2位）。

更新后的VBA代码可实现重命名功能，但处理8个文件时会重复处理第一个文件，其余文件正常，现寻求该异常的原因。

第一段初始VBA代码 #

Sub test()
    Dim myDir As String
    myDir = "e:\Test\"
    If Dir(myDir, vbDirectory) = "" Then
        MsgBox "Folder not found"
        Exit Sub
    End If
    SeachFiles myDir, "*.pdf"
End Sub
 

Private Sub SeachFiles(myDir, fn)
Dim fso As Object, myFolder As Object, myFile As Object
Dim temp As String, m As Object, NewName As String, OldName As String
Set fso = CreateObject("Scripting.FileSystemObject")
With CreateObject("VBScript.RegExp")
    .Pattern = "(?:\D)(\d{1,2})(\d{1,2})(\d{4})(?:\D)"
    .ignorecase = True
    For Each myFile In fso.getfolder(myDir).Files
        If myFile.Name Like fn Then
            If .test(myFile.Name) Then
                If Not IsFileOpen(myDir & "\" & myFile.Name) Then
                    Set m = .Execute(myFile.Name)(0)
                    temp = Format$(DateValue(m.submatches(2) & "/" & _
                      m.submatches(0) & "/" & m.submatches(1)), "yyyymmdd")
                    NewName = myDir & "\" & Application.Replace(myFile.Name, _
                      m.firstindex + 2, m.Length - 1, temp)
                    OldName = myDir & "\" & myFile.Name
                    Name OldName As NewName
                Else
                    MsgBox "Can not process " & myFile.Name & _
                      vbLf & "Currently open"
                End If
            End If
        End If
    Next
    For Each myFolder In fso.getfolder(myDir).subfolders
        SeachFiles myFolder.Path, fn
    Next
End With
End Sub

Function IsFileOpen(fName As String) As Boolean
    Dim ff As Integer, errNum As Integer
    On Error Resume Next
    ff = FreeFile
    Open fName For Input Lock Read As #ff
    Close ff
    errNum = Err
    On Error GoTo 0
    IsFileOpen = (errNum <> 0)
End Function

第二段更新后的VBA代码 #

'this function checks to see if a folder/file exists
Function FileFolderExists(sPathFile As String) As Boolean
  FileFolderExists = False
  On Error Resume Next
  If Not Dir(sPathFile, vbDirectory) = vbNullString Then FileFolderExists = True
  On Error GoTo 0
End Function 'FileFolderExists

Sub Macro1()
    Dim text As String
    Dim secresult, oneresult, tworesult, mresult, dresult As String
    Dim finalresult As String
    Dim first, testlen, datelen As Integer
    
    Dim sFilePath As String
    Dim sFileName As String
    Dim prfx As String
    Dim sufx As String
    Dim oName As String
    Dim nName As String
    Dim lNum As Long
      
         
    'Specify File Path from Input Screen
    sFilePath = [Source]
    
    sFilePath = Application.WorksheetFunction.Clean(Trim(sFilePath))
        If sFilePath = vbNullString Then
        MsgBox "Source folder must be entered" & vbLf & vbLf & _
           "Unable to continue with rename", vbCritical + vbExclamation
        GoTo QuickExit
    End If

    If InStr(Len(sFilePath), sFilePath, "\") = 0 Then sFilePath = sFilePath & "\"
    If Not FileFolderExists(sFilePath) Then
        MsgBox "The input folder does not appear to be valid" & vbLf & vbLf & _
           "Unable to continue with rename", vbCritical + vbExclamation
        GoTo QuickExit
    End If
    
    'Specify new suffix
    sufx = ".pdf"
    
    'Check for back slash
    If Right(sFilePath, 1) <> "\" Then
        sFilePath = sFilePath & "\"
    End If
       
    sFileName = Dir(sFilePath & "*.pdf")
   
    lNum = 0 ' File Counter
    
'   Loop through all PDF files in folder
    Do While Len(sFileName) > 0
    
        'Find length of File Name
        testlen = Len(sFileName)
        first = InStr(sFileName, "_")
        datelen = testlen - first
              
        If datelen = 12 Then
            secresult = Mid(sFileName, first + 1, 8)
            oneresult = Left(secresult, 4)
            mresult = Right(oneresult, 2)
            dresult = Left(oneresult, 2)
            tworesult = Right(secresult, 4)
            finalresult = tworesult & mresult & dresult
           
        ElseIf datelen = 11 Then
            secresult = Mid(sFileName, first + 1, 7)
            oneresult = Left(secresult, 3)
            mresult = Right(oneresult, 2)
            dresult = Left(oneresult, 1)
            tworesult = Right(secresult, 4)
            finalresult = tworesult & mresult & "0" & dresult
                       
        End If
          
        'Specify new prefix
        prfx = Left(sFileName, first)
        
        'Get full path and name of file
        oName = sFilePath & sFileName
        'Build new path and name
        nName = sFilePath & prfx & finalresult & sufx
        'Rename file
        Name oName As nName
      
        'Set the fileName to the next available file
        sFileName = Dir
        
        lNum = lNum + 1 ' Increment File Counter
    Loop
   
    MsgBox "File Renaming complete!" & vbLf & vbLf & lNum & " file/s renamed"
        
QuickExit:
    
End Sub

异常原因分析 #

问题核心在于**Dir函数的遍历机制与文件重命名的冲突**：

1. Dir函数基于文件夹实时状态遍历，初始调用Dir(sFilePath & "*.pdf")获取第一个匹配文件名。
2. 重命名第一个文件后，新文件名仍符合*.pdf规则，且在默认名称排序中，新文件名大概率排在未处理原文件前面（例如原文件John Doe_010524.pdf重命名为John Doe_20240501.pdf，数字排序优先级更高）。
3. 循环执行sFileName = Dir()时，Dir会从当前遍历位置继续查找匹配项，刚生成的重命名文件会被当作新匹配项读取，导致第一个文件被重复处理。

解决方法 #

先将所有待处理文件名一次性读取到数组中，再遍历数组执行重命名，规避文件夹实时变化的影响：

Sub Macro1()
    Dim text As String
    Dim secresult, oneresult, tworesult, mresult, dresult As String
    Dim finalresult As String
    Dim first, testlen, datelen As Integer
    
    Dim sFilePath As String
    Dim sFileName As String
    Dim prfx As String
    Dim sufx As String
    Dim oName As String
    Dim nName As String
    Dim lNum As Long
    ' 新增数组存储文件名
    Dim fileList() As String
    Dim i As Integer
    Dim fileCount As Integer
      
         
    'Specify File Path from Input Screen
    sFilePath = [Source]
    
    sFilePath = Application.WorksheetFunction.Clean(Trim(sFilePath))
        If sFilePath = vbNullString Then
        MsgBox "Source folder must be entered" & vbLf & vbLf & _
           "Unable to continue with rename", vbCritical + vbExclamation
        GoTo QuickExit
    End If

    If InStr(Len(sFilePath), sFilePath, "\") = 0 Then sFilePath = sFilePath & "\"
    If Not FileFolderExists(sFilePath) Then
        MsgBox "The input folder does not appear to be valid" & vbLf & vbLf & _
           "Unable to continue with rename", vbCritical + vbExclamation
        GoTo QuickExit
    End If
    
    'Specify new suffix
    sufx = ".pdf"
    
    'Check for back slash
    If Right(sFilePath, 1) <> "\" Then
        sFilePath = sFilePath & "\"
    End If
       
    ' 第一步：收集所有PDF文件名到数组
    sFileName = Dir(sFilePath & "*.pdf")
    fileCount = 0
    Do While Len(sFileName) > 0
        fileCount = fileCount + 1
        ReDim Preserve fileList(1 To fileCount)
        fileList(fileCount) = sFileName
        sFileName = Dir
    Loop
    
    ' 第二步：遍历数组处理重命名
    lNum = 0 ' File Counter
    For i = 1 To fileCount
        sFileName = fileList(i)
        
        'Find length of File Name
        testlen = Len(sFileName)
        first = InStr(sFileName, "_")
        datelen = testlen - first
              
        If datelen = 12 Then
            secresult = Mid(sFileName, first + 1, 8)
            oneresult = Left(secresult, 4)
            mresult = Right(oneresult, 2)
            dresult = Left(oneresult, 2)
            tworesult = Right(secresult, 4)
            finalresult = tworesult & mresult & dresult
           
        ElseIf datelen = 11 Then
            secresult = Mid(sFileName, first + 1, 7)
            oneresult = Left(secresult, 3)
            mresult = Right(oneresult, 2)
            dresult = Left(oneresult, 1)
            tworesult = Right(secresult, 4)
            finalresult = tworesult & mresult & "0" & dresult
                       
        End If
          
        'Specify new prefix
        prfx = Left(sFileName, first)
        
        'Get full path and name of file
        oName = sFilePath & sFileName
        'Build new path and name
        nName = sFilePath & prfx & finalresult & sufx
        'Rename file
        Name oName As nName
      
        lNum = lNum + 1 ' Increment File Counter
    Next i
   
    MsgBox "File Renaming complete!" & vbLf & vbLf & lNum & " file/s renamed"
        
QuickExit:
    
End Sub

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