Consulting

Results 1 to 20 of 20

Thread: Rename Files By Adding Last Modified Date

  1. #1

    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

  2. #2
    Try this 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

  3. #3
    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

  4. #4
    VBAX Mentor Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    347
    Location
    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
    ' 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
    Sincerely,
    Leith Ross

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

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

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

  8. #8
    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.



    Testing.jpgRun time error 76.jpg

  9. #9
    Put the excel file that has the macro outside the folder and you can use the full path instead
    strFolder="C:\Users\123\Pictures\Testing\"

  10. #10
    Thanks YasserKhalil for reviewing...It works perfectly !!

  11. #11
    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

  12. #12
    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.

  13. #13
    VBAX Mentor Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    347
    Location
    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...

    ' 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
    Last edited by Leith Ross; 10-08-2016 at 11:53 AM. Reason: Color tags not working in code block
    Sincerely,
    Leith Ross

  14. #14
    Thanks a lot Mr. Leith Ross
    I tested the last updated code I got error : File Already Exists at this line
     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?

  15. #15
    VBAX Mentor Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    347
    Location
    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.

    ' 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
    Sincerely,
    Leith Ross

  16. #16
    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

  17. #17
    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

  18. #18
    VBAX Mentor Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    347
    Location
    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.
    Sincerely,
    Leith Ross

  19. #19

    Thank You

    Hi Leith,

    Thanks for the code, it helped me as well.

    Regards,
    Gowtham

  20. #20
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,331
    This code should be sufficient:

    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •