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