Rename Files By Adding Last Modified Date

Please help me in macro how to rename all the files (such as excel/PDF/jpg format) in folder / subfolder with original filename & last modified date of the related file via VBA Code.
Actually, I could find VBA Code for Filename with Current date in the forum. But, there are no records/forums for renaming all the files in folder / subfolder with the filename & last modified date / creation date.


Current file name : filename1, filename2
New file name : filename1 MM-DD-YY , filename2 MM-DD-YY

Try this code

Code:

---

Sub Rename_All_Files_In_Given_Folder()
    Dim FileSystem      As Object
    Dim strFolder      As String

    'Change Folder Path To Suit
    strFolder = ThisWorkbook.Path & "\Test Folder\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(strFolder)

    MsgBox "Done...", 64
End Sub

Sub DoFolder(Folder)
    Dim SubFolder      As Object
    Dim File            As Object
    Dim myPath          As String
    Dim lResult        As Date
    Dim strDate        As String
    Dim strFile        As String
    Dim strExten        As String
    Dim strDir          As String

    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next SubFolder

    For Each File In Folder.Files
        myPath = File.Path

        strDir = Left(myPath, InStrRev(myPath, "\"))
        strFile = CreateObject("Scripting.FileSystemObject").GetBaseName(File.Name)
        lResult = Split(FileDateTime(myPath), " ")(0)
        strDate = Format(lResult, "MM-DD-YYYY")
        strExten = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))

        If Not InStr(strFile, strDate) > 0 Then
            Name myPath As strDir & strFile & " " & strDate & strExten
        End If
    Next File
End Sub

---

Hello, YasserKhalil
Thank you for the quick response!

After changing the path in Module 1. I added the button to run the code and it did not work. Also, I removed the button & tried to run with Alt F8. Nevertheless, The Pop-up box showed the error "run-time error '76' : Path not found". when I pressed debug, DoFolder FileSystem.GetFolder(strFolder) is highlighted.

In this case, would you please help to review it again? Meanwhile, is it possible to have the Pop-up box to select path instead of the change of the code in Module?

Tks & rgds,
Joey

Hello Joey,

This macro will let you select the folder you want to search using the File Picker Dialog. Call the Run macro to display it and start renaming the files.

When I read your post, I was not sure if you were only going 1 subfolder down from the parent folder or if you were looking to change files in subfolders of subfolders until there are no more subfolders.

This macro will let you select the depth of recursion for the subfolders. A positive number will limit the recursive search of subfolders to no more than the given number. Zero will search only the parent folder. A negative 1 will search the parent folder and all the subfolders of subfolders until there are no more to search.

Each file's name will have the date it was last modified appended to the original name in the format MM-dd-yyy. This applies to either files with or without extensions.

You can change the level for the subfolder search in the macro Run. It is the second argument in the call to the macro RenameAllFiles.


Macro Code to add the date last modified to all files

Code:

---

' Written:  October 07, 2016
' Author:  Leith Ross
' Summary  Renames all files in a folder by adding the last date modified to the file name.
'          The date format is MM-dd-yy. The depth of subfolder recursion can be controlled.
'          -1 is used for the parent folder and all subfolders of subfolders ad infinitum.
'          0 (zero) renames only the files in the parent folder.
'          Any positive number will stop recursion at that depth.


Sub RenameAllFiles(ByVal FolderPath As Variant, Optional SubFolderDepth As Long)


    Dim File        As Object
    Dim Files      As Object
    Dim FileExt    As String
    Dim Folder      As Variant
    Dim LastDate    As Variant
    Dim NewName    As String
    Dim oShell      As Object
    Dim SubFolder  As Object
    Dim SubFolders  As Variant
    Dim x          As Long
   
        Set oShell = CreateObject("Shell.Application")
       
            Set Folder = oShell.Namespace(FolderPath)
                If Folder Is Nothing Then
                    MsgBox "The Folder Path was Not Found..." & vbLf & vbLf & FolderPath, vbOKOnly + vbExclamation
                    Exit Sub
                End If
               
            If Folder.Self.Type Like "*zipped*" Then Exit Sub
           
            Set Files = Folder.Items
                Files.Filter 64, "*.*"
           
                For Each File In Files
                    LastDate = File.ModifyDate
                    x = InStrRev(File.Name, ".")
                        If x > 0 Then
                            FileExt = Right(File.Name, Len(File.Name) - x + 1)
                            NewName = Left(File.Name, x - 1) & " " & Format(LastDate, "mm-dd-yy") & FileExt
                        Else
                            NewName = File.Name & " " & Format(LastDate, "mm-dd-yy")
                        End If
                    Name File.Path As Folder.Self.Path & "\" & NewName
                Next File
               
            Set SubFolders = Folder.Items
                SubFolders.Filter 32, "*"
               
                If SubFolderDepth <> 0 Then
                    For Each SubFolder In SubFolders
                        Call RenameAllFiles(SubFolder, SubFolderDepth - 1)
                    Next SubFolder
                End If
           
End Sub




Sub Run()
   
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            If .SelectedItems.Count = 0 Then Exit Sub
            Call RenameAllFiles(.SelectedItems(1), -1)    ' -1 searches all subfolders. 0 (zero) only the parent folder, and >= 1 sets the maximum number of subfolders to search.
        End With


End Sub

---

make sure there is \ at the end of path ..
What is your office version?

Great Mr. Leith Ross
That's wonderful and great .. Thanks for sharing it
The code affects the extension of files

Hello, Leith
Thank you for the reply!!

I just ran the code & the path can be selected now. But, the file type of all files were changed to unknown file type in the folder. Also, when I opened those files, the "Open with" was Pop-up for each file.

Tks & rgds,
Joey

Hi, Yasserkhalil
I placed the Excel file with your advised Code in the testing folder - C:\Users\123\Pictures\Testing.
Then, I changed the folder name as per your advice.....strFolder = ThisWorkbook.Path & "\Testing\" and ran the Code. Nevertheless, it showed run time error '76'. Enclosed the captures for your reviewing.

Fyi, I'm using Office 2010 in the office and I use it at home as well.



Attachment 17293Attachment 17294

Put the excel file that has the macro outside the folder and you can use the full path instead

Code:

---

strFolder="C:\Users\123\Pictures\Testing\"

---

Thanks YasserKhalil for reviewing...It works perfectly :clap:!!

You're welcome. Glad I can offer some help for you

Waiting for Mr. Leith Ross to fix the extension as his code is the best

Thanks again!! YasserKhalil......Your Code help me to fix the daily issue.

Regarding Leith's Code, I'm looking forward seeing his reply too. It will be great to help my colleague who does not know the Macro much.

Hello Joey,

Bollocks, I keep forgetting the the Shell object has a option to "Hide extensions of known file types" which is the system default setting. I have that disabled on machine. I have made a few changes to the code and tested it with file extensions and without file extensions options. It works now.

Here is the updated code...

Code:

---

' Written:  October 07, 2016
' Updated:  October 08, 2016
' Author:  Leith Ross
' Summary  Renames all files in a folder by adding the last date modified to the file name.
'          The date format is MM-dd-yy. The depth of subfolder recursion can be controlled.
'          -1 is used for the parent folder and all subfolders of subfolders ad infinitum.
'          Zero renames only the files in the parent folder.
'          Any positive number will stop recursion at that depth.


Global Const SFVVO_SHOWEXTENSIONS As Long = 2


Sub RenameAllFiles(ByVal FolderPath As Variant, Optional SubFolderDepth As Long)


    Dim File        As Object
    Dim FileExt    As String
    Dim FileName    As String
    Dim Files      As Object
    Dim Folder      As Variant
    Dim LastDate    As Variant
    Dim NewName    As String
    Dim oShell      As Object
    Dim SubFolder  As Object
    Dim SubFolders  As Variant
    Dim x          As Long
   


        Set oShell = CreateObject("Shell.Application")
       
            Set Folder = oShell.Namespace(FolderPath)
                If Folder Is Nothing Then
                    MsgBox "The Folder Path was Not Found..." & vbLf & vbLf & FolderPath, vbOKOnly + vbExclamation
                    Exit Sub
                End If
               
            If Folder.Self.Type Like "*zipped*" Then Exit Sub
           
            Set Files = Folder.Items
                Files.Filter 64, "*.*"
           
                For Each File In Files
                    LastDate = File.ModifyDate
                   
                    FileName = IIf(Not oShell.GetSetting(SFVVO_SHOWEXTENSIONS), Dir(File.Name), File.Name)
                   
                    x = InStrRev(FileName, ".")
                        If x > 0 Then
                            FileExt = Right(FileName, Len(FileName) - x + 1)
                            NewName = Left(FileName, x - 1) & " " & Format(LastDate, "mm-dd-yy") & FileExt
                        Else
                            NewName = FileName & " " & Format(LastDate, "mm-dd-yy")
                        End If
                       
                    Name File.Path As Folder.Self.Path & "\" & NewName
                Next File
               
            Set SubFolders = Folder.Items
                SubFolders.Filter 32, "*"
               
                If SubFolderDepth <> 0 Then
                    For Each SubFolder In SubFolders
                        Call RenameAllFiles(SubFolder, SubFolderDepth - 1)
                    Next SubFolder
                End If
           
End Sub




Sub Run()
   
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            If .SelectedItems.Count = 0 Then Exit Sub
            Call RenameAllFiles(.SelectedItems(1), -1)
        End With


End Sub

---

Thanks a lot Mr. Leith Ross
I tested the last updated code I got error : File Already Exists at this line

Code:

---

Name File.Path As Folder.Self.Path & "\" & NewName

---

There is no file with the name of date ..
In fact the previous code was working well except the point of extension...
Is it possible to keep the extension then restore it again?

Hello Yasser and Joey,

I made a mistake in setting the variable FileName. That is now fixed. I added a check to test if the file already has a date added. You don't want to add another date after an existing date, right?

Here is the amended code.

Code:

---

' Written:  October 07, 2016
' Author:  Leith Ross
' Summary  Renames all files in a folder by adding the last date modified to the file name.
'          The date format is MM-dd-yy. The depth of subfolder recursion can be controlled.
'          -1 is used for the parent folder and all subfolders of subfolders ad infinitum.
'          Zero renames only the files in the parent folder.
'          Any positive number will stop recursion at that depth.


Global Const SFVVO_SHOWEXTENSIONS As Long = 2


Sub RenameAllFiles(ByVal FolderPath As Variant, Optional SubFolderDepth As Long)


    Dim File        As Object
    Dim FileExt    As String
    Dim FileName    As String
    Dim Files      As Object
    Dim Folder      As Variant
    Dim LastDate    As Variant
    Dim NewName    As String
    Dim oShell      As Object
    Dim SubFolder  As Object
    Dim SubFolders  As Variant
    Dim x          As Long
   


        Set oShell = CreateObject("Shell.Application")
       
            Set Folder = oShell.Namespace(FolderPath)
                If Folder Is Nothing Then
                    MsgBox "The Folder Path was Not Found..." & vbLf & vbLf & FolderPath, vbOKOnly + vbExclamation
                    Exit Sub
                End If
               
            If Folder.Self.Type Like "*zipped*" Then Exit Sub
           
            Set Files = Folder.Items
                Files.Filter 64, "*.*"
           
                For Each File In Files
                    LastDate = File.ModifyDate
                   
                    ' Get the file name with the extension.
                    FileName = IIf(Not oShell.GetSetting(SFVVO_SHOWEXTENSIONS), Dir(File.Path), File.Name)
                   
                    ' Don't change the file name if a date has been added.
                    If Not (FileName Like "* ##-##-##.*" Or File Like "* ##-##-##") Then
                        x = InStrRev(FileName, ".")
                       
                        If x > 0 Then
                            FileExt = Right(FileName, Len(FileName) - x + 1)
                            NewName = Left(FileName, x - 1) & " " & Format(LastDate, "mm-dd-yy") & FileExt
                        Else
                            NewName = FileName & " " & Format(LastDate, "mm-dd-yy")
                        End If
                       
                        Name File.Path As Folder.Self.Path & "\" & NewName
                    End If
                Next File
               
            Set SubFolders = Folder.Items
                SubFolders.Filter 32, "*"
               
                If SubFolderDepth <> 0 Then
                    For Each SubFolder In SubFolders
                        Call RenameAllFiles(SubFolder, SubFolderDepth - 1)
                    Next SubFolder
                End If
           
End Sub




Sub Run()
   
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            If .SelectedItems.Count = 0 Then Exit Sub
            Call RenameAllFiles(.SelectedItems(1), -1)
        End With


End Sub

---

Hello, Leith
The revised Code works Great. Thank you for fixing it!

Again, I really appreiate Yasser & Leith for your help for saving the time in my dailly works:bow:

Now it is perfect and wonderful
Thank you very much for your time and effort
In fact I am fond of your solutions. They are distinguished like you
Best Regards

Hello Joey and Yasser,

Sorry it took me 3 tries to get it right. Thanks for your patience and kind words. If there is anything you want me to explain, just ask.

Hi Leith,

Thanks for the code, it helped me as well.

Regards,
Gowtham

This code should be sufficient:

Code:

---

Sub M_snb()
  With Application.FileDialog(4)
    If .Show Then
      sn = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & .SelectedItems(1) & "*.*"" /b/a-d/s").stdout.readall, vbCrLf)
           
      For j = 0 To UBound(sn) - 1
        Name sn(j) As Left(sn(j), Len(sn(j)) - 6) & Replace(Right(sn(j), 6), ".", Format(FileDateTime(sn(j)), "_yyyymmddhhmmss."))
      Next
    End If
  End With
End Sub

---