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. :-)



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

[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