Add Date to all files in a folder

[trez]

Hi,

I need some help on making a VBA macro to add date "DDMMYYYY" to the end of all files in a specific folder.

Let me know if you need anything else.

Thanks

[snb]

Do you need help so you will be able to do it yourself or do you want a turn key solution ?

[trez]

Do you need help so you will be able to do it yourself or do you want a turn key solution ?

Turn Key definitely.

[Paul_Hossler]

If it's a one time thing, there are plenty of 'file rename' utilities that can add it to the end

I use 'Lupas Rename 2000' at http://rename.lupasfreeware.org/download.php

It's been out a long time, but has the features I use, including adding a suffix to file names in folders and sub-folders, as well as a lot of other things

[trez]

i have a macro to copy files to a different folder. Then i wanted to add todays date as DDMMYYYY in that folder. I didn't want to use another application and use it in excel.

[Paul_Hossler]

OK, NP

What's your macro?

As you copy each file, could you just add

 .... & "-" & Format (Date, "ddmmyyyy")

to each file name?

[DimSimonAsMe]

Hi there,

The above proposed approach is quite simple - I believe you will use it. But If you still want a bit another approach(for other tasks), I can give you the following Sub, which implies active "Microsoft Scripting Runtime" (it is easily activated through: "tools" > "references" and check the box "Microsoft Scripting Runtime")

The proposed approach is flexible in terms of:
- writing in the dialog window any date or other tag you may ever want (Region/Division etc) to use in files' names
- picking the folder you want (if you need subfolders too - the code needs some corrections)

Sub AddDateToAllFilesInFolder()
Dim TargetFolder As Scripting.Folder
    Dim FileToChange As Scripting.File
    Dim DateToAdd As String
    Dim TargetFolderPath As String
    Dim fso As Scripting.FileSystemObject
DateToAdd = InputBox("Inut The Date To Add or any other tag you wish to be used in files's names", "Add Date/Tag")
Application.FileDialog(msoFileDialogFolderPicker).Show
    TargetFolderPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Set fso = New Scripting.FileSystemObject
    Set TargetFolder = fso.GetFolder(TargetFolderPath)
For Each FileToChange In TargetFolder.Files
        FileToChange.Name = Replace(FileToChange.Name, "." & fso.GetExtensionName(FileToChange.Name), "") & " " & DateToAdd & "." & fso.GetExtensionName(FileToChange.Name)
    Next FileToChange
End Sub

[trez]

OK, NP

What's your macro?

As you copy each file, could you just add

 .... & "-" & Format (Date, "ddmmyyyy")

to each file name?

This is the current code. I'm using how would i implement this?

Sub Copy_Folder()
'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
    Dim fso As Object
    Dim FromPath As String
    Dim ToPath As String
FromPath = "C:\Users\tbent_000\Desktop\New folder"  '<< Change
    ToPath = "C:\Users\tbent_000\Desktop\New folder1\"    '<< Change
If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If
If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If
Set fso = CreateObject("scripting.filesystemobject")
If fso.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If
fso.CopyFolder Source:=FromPath, Destination:=ToPath
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub

[DimSimonAsMe]

So you have sub folders also?

[snb]

Please do not quote !
Please use code tags around VBA code !

[Paul_Hossler]

I didn't realize you were using FSO and had subfolders

Try something like this then but you'll have to copy one file at a time

Option Explicit
Dim oFSO As Object
Dim FromPath As String
Dim ToPath As String

Sub Copy_Folders()
    
    FromPath = "L:\Test"
    ToPath = "L:\TestOut"
    
    If Right(FromPath, 1) = "\" Then FromPath = Left(FromPath, Len(FromPath) - 1)
    If Right(ToPath, 1) = "\" Then ToPath = Left(ToPath, Len(ToPath) - 1)
    
    Set oFSO = CreateObject("scripting.filesystemobject")
    
    If Not oFSO.FolderExists(FromPath) Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If
    
    pvtCopyFolder oFSO.GetFolder(FromPath)
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub

Private Sub pvtCopyFolder(FolderFrom As Object)
    
    Dim oSubFolder As Object
    Dim oFile As Object
    Dim sDestPath As String, sDestFile As String
    Dim i As Long
    
    sDestPath = FolderFrom.Path
    sDestPath = Right(sDestPath, Len(sDestPath) - Len(FromPath))
    If Left(sDestPath, 1) = "\" Then sDestPath = Right(sDestPath, (Len(sDestPath) - 1))
    sDestPath = ToPath & "\" & sDestPath
    
    If Not oFSO.FolderExists(sDestPath) Then oFSO.CreateFolder (sDestPath)
    
    
    For Each oSubFolder In FolderFrom.SubFolders
        pvtCopyFolder oSubFolder
    Next
    
    For Each oFile In FolderFrom.Files
    
        sDestFile = sDestPath & "\" & oFSO.getbasename(oFile.Path) & "-" & Format(Date, "ddmmyyyy") & "." & oFSO.getextensionname(oFile.Path)
        
        Call oFSO.copyfile(oFile.Path, sDestFile, True)
    Next
End Sub

[DimSimonAsMe]

I'd like to give you my version. It makes almost no changes to your code (which you thoroughly understand) - just a line - to call a procedure. Hope you will like it. :-)

[VBA]

Sub Copy_Folder()
''This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
Dim fso As Object
Dim FromPath As String
Dim ToPath As String
FromPath = "D:\Docs\Excel trials\Add Date To Files in Folder\Target Folder" '<< Change
ToPath = "D:\Docs\Excel trials\Add Date To Files in Folder\Destination folder" '<< Change
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set fso = CreateObject("scripting.filesystemobject")
If fso.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
Exit Sub
End If
fso.CopyFolder Source:=FromPath, Destination:=ToPath
Call Add_Date_to_all_files_in_a_folder_and_subfolders(ToPath)
MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub




Sub Add_Date_to_all_files_in_a_folder_and_subfolders(ToPath As String)
Dim fso As Scripting.FileSystemObject
Dim FileToChange As Scripting.File
Dim DateToAdd As String
Dim Asubfolder As Scripting.Folder
Set fso = New Scripting.FileSystemObject
DateToAdd = Format(Date, "ddmmyyyy")
For Each FileToChange In fso.GetFolder(ToPath).Files
FileToChange.Name = Replace(FileToChange.Name, "." & fso.GetExtensionName(FileToChange.Name), "") & " " & DateToAdd & "." & fso.GetExtensionName(FileToChange.Name)
Next FileToChange
For Each Asubfolder In fso.GetFolder(ToPath).SubFolders
Call Add_Date_to_all_files_in_a_folder_and_subfolders(Asubfolder.Path)
Next Asubfolder
End Sub
[/VBA]

[snb]

I'll give you my version:

Sub M_snb()
    sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir G:\OF\* /b/s/a-d").stdout.readall, vbCrLf), ".")
    
    For Each it In sn
       Name it As Replace(it, ".", Format(Date, "yyyymmdd."))
    Next
End Sub

[trez]

I didn't realize you were using FSO and had subfolders

Try something like this then but you'll have to copy one file at a time

Option Explicit
Dim oFSO As Object
Dim FromPath As String
Dim ToPath As String

Sub Copy_Folders()
    
    FromPath = "L:\Test"
    ToPath = "L:\TestOut"
    
    If Right(FromPath, 1) = "\" Then FromPath = Left(FromPath, Len(FromPath) - 1)
    If Right(ToPath, 1) = "\" Then ToPath = Left(ToPath, Len(ToPath) - 1)
    
    Set oFSO = CreateObject("scripting.filesystemobject")
    
    If Not oFSO.FolderExists(FromPath) Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If
    
    pvtCopyFolder oFSO.GetFolder(FromPath)
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub

Private Sub pvtCopyFolder(FolderFrom As Object)
    
    Dim oSubFolder As Object
    Dim oFile As Object
    Dim sDestPath As String, sDestFile As String
    Dim i As Long
    
    sDestPath = FolderFrom.Path
    sDestPath = Right(sDestPath, Len(sDestPath) - Len(FromPath))
    If Left(sDestPath, 1) = "\" Then sDestPath = Right(sDestPath, (Len(sDestPath) - 1))
    sDestPath = ToPath & "\" & sDestPath
    
    If Not oFSO.FolderExists(sDestPath) Then oFSO.CreateFolder (sDestPath)
    
    
    For Each oSubFolder In FolderFrom.SubFolders
        pvtCopyFolder oSubFolder
    Next
    
    For Each oFile In FolderFrom.Files
    
        sDestFile = sDestPath & "\" & oFSO.getbasename(oFile.Path) & "-" & Format(Date, "ddmmyyyy") & "." & oFSO.getextensionname(oFile.Path)
        
        Call oFSO.copyfile(oFile.Path, sDestFile, True)
    Next
End Sub

Worked perfectly, how would i take off the sub folder option and make it faster

[Paul_Hossler]

Probably something like this

Option Explicit
 
Sub Copy_A_Folder()
    Dim FromPath As String, ToPath As String
    Dim oFile As Object, oFolder As Object, oFSO As Object
    Dim sDestPath As String, sDestFile As String
     
    FromPath = "L:\Test"
    ToPath = "L:\TestOut1"
     
    If Right(FromPath, 1) = "\" Then FromPath = Left(FromPath, Len(FromPath) - 1)
    If Right(ToPath, 1) = "\" Then ToPath = Left(ToPath, Len(ToPath) - 1)
     
    Set oFSO = CreateObject("scripting.filesystemobject")
     
    If Not oFSO.FolderExists(FromPath) Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If
     
     
    sDestPath = FromPath
    sDestPath = Right(sDestPath, Len(sDestPath) - Len(FromPath))
    If Left(sDestPath, 1) = "\" Then sDestPath = Right(sDestPath, (Len(sDestPath) - 1))
    sDestPath = ToPath & "\" & sDestPath
 
    If Not oFSO.FolderExists(ToPath) Then oFSO.CreateFolder (ToPath)
    Set oFolder = oFSO.GetFolder(FromPath)
     
    For Each oFile In oFolder.Files
        sDestFile = sDestPath & "\" & oFSO.getbasename(oFile.Path) & "-" & Format(Date, "ddmmyyyy") & "." & oFSO.getextensionname(oFile.Path)
        Call oFSO.copyfile(oFile.Path, sDestFile, True)
    Next
     
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
End Sub