excelregexvba

RegEx and Excel VBA for date extraction from a filename where date can be dmmyy or ddmmyy


I am trying to rename a set of pdf filenames in the form:
"Joe BLOGGS_3052023.pdf" or "Joe BLOGGS_31052023.pdf"
("FirstName SURNAME_dmmyy" or "FirstName SURNAME_ddmmyy").

The month is always two digits. Only the day can be either dd or d.

I need the output of the filename to be:
Joe BLOGGS_20230503.pdf or Joe BLOGGS_20230531.pdf

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

Here is my new code. It works BUT it looped through and did the first of 8 files twice. All the rest are fine. I don't know why it did one file again!!

'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


Solution

  • Whilst improving your VBA skills, can I suggest in the interim, the Windows OS task is more suited to a batch file like this :-

    ren-_dmmyyyy-test.cmd

    @echo off
    
    cd /d "e:\test"
    
    SETLOCAL ENABLEDELAYEDEXPANSION
    
    for %%f in (*.pdf) do (
    set "$OldName=%%f"
    set "$y=!$OldName:~-8,-4!"
    if "!$OldName:~-12,-8!" == "2023" (echo some files already renamed&&goto abort)
    set "test=!$OldName:~-12,-11!"
    if !test!==_ (
    set "$mmdd=!$OldName:~-10,-8!0!$OldName:~-11,-10!"
    echo ren "%%f"  "!$OldName:~0,-12!_!$y!!$mmdd!.pdf"
    ) else (
    set "$mmdd=!$OldName:~-10,-8!!$OldName:~-12,-10!"
    echo ren "%%f" "!$OldName:~0,-13!_!$y!!$mmdd!.pdf"
    ) 
    )
    :abort
    cd /d "%~dp0"
    

    Note the echo before the 2 ren lines, is so that you can test, that it is what is required and if happy it solves an XY problem, then remove those 2 echo's.

    Answer as VBA

    based on above can be something like this

    Private Sub SearchFiles(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")
        For Each myFile In fso.getfolder(myDir).Files
        OldFile = myFile
        temp$ = myFile.Name
        Start$ = Left(temp$, Len(temp$) - 12)
        ext = Right(temp$, 4)
        yyyy = Left(Right(temp$, 8), 4)
            dmm = Left(Right(temp$, 12), 4)
        If Left(dmm, 1) = "_" Then
            MsgBox "Name " & OldFile & " As " & Start$ & "_" & yyyy & Right(dmm, 2) & "0" & Mid(dmm, 2, 1) & ext
        Else
            MsgBox "Name " & OldFile & " As " & Start$ & yyyy & Right(dmm, 2) & Left(dmm, 2) & ext
        End If
    
        Next
    End Sub
    

    If happy that is what is wanted adjust the last two actions by remove MsgBox " and edit command to Name &" "& etc.