VBA - Iteration to copy & rename files in folder


Well-known Member
Apr 6, 2006
I have about 30 files to copy to a new folder & rename the files with the date format ddmmyyyy added at the end of the filename before the Ext identifier ie
filename.doc? to filename ddmmyyyy.doc? (I also need to modify actual files and want to do this via a macro iteration but one step at a time.

This project will be on going and having to do this 2 or 3 times a week. There are also repetitive tasks that need to happen within the files that need opening up, changing and saving. But one step at a time.

Here is a sample of an actual file name change
1.2 Annual Objectives.doc to 1.2 Annual Objectives ddmmyyyy.doc
The problem is that I have varierty of filetypes xls, xlsx, doc, docx, pdf etc

to replace the "." with "ddmmyyyy." I have this code
 strName = Replace(Find(".", A2, 6), " " & Format(Now(), "ddmmyyyy") & ".")
But the "(Find(" is not working. Below is my full code with redundant stuff that I haven't removed yet.

Sub Copy_and_Rename_To_New_Folder()
    Dim objFSO As FileSystemObject, objFolder As Folder, PathExists As Boolean
    Dim objFile As File, strSourceFolder, Mnth, Dmnth, Yr, Dyr As String, strDestFolder As String
    Dim x, Counter As Integer, Overwrite As String, strNewFileName As String
    Dim strName As String, strMid As String, strExt As String, val As String
    Application.ScreenUpdating = False 'turn screenupdating off
    Application.EnableEvents = False 'turn events off
    Mnth = DatePart("m", (DateAdd("m", -1, Date))) 'Source Month
    Yr = DatePart("yyyy", (DateAdd("m", -1, Date))) 'Source Year
    Dyr = Year(Date) 'Desination Month
    Dmnth = Month(Date) 'Destination Year
    If Len(Mnth) = 1 Then Mnth = "0" & Mnth
    If Len(Dmnth) = 1 Then Dmnth = "0" & Dmnth
    strSourceFolder = "U:\Ant\WSMP Supreme Manual Master 2015" 'Source path
    val = InputBox("Enter Company name", "Company Name Input")
    strDestFolder = "U:\Ant\" & val  'destination path
     'below will verify that the specified destination path exists, or it will create it:
    On Error Resume Next
    x = GetAttr(strDestFolder) And 0
    If Err = 0 Then 'if there is no error, continue below
        PathExists = True 'if there is no error, set flag to TRUE
        Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
        "Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
         'message to alert that you may overwrite files of the same name since folder exists
        If Overwrite <> vbYes Then Exit Sub 'if the user clicks YES, then exit the routine..
Else: 'if path does NOT exist, do the next steps
        PathExists = False 'set flag at false
        If PathExists = False Then MkDir (strDestFolder) 'If path does not exist, make a new one
    End If 'end the conditional testing
    On Error GoTo ErrHandler
    Set objFSO = New FileSystemObject 'creates a new File System Object reference
    Set objFolder = objFSO.GetFolder(strSourceFolder) 'get the folder
    Counter = 0 'set the counter at zero for counting files copied
    If Not objFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section
    For Each objFile In objFolder.Files 'for every file in the folder...
        'strName = Left(objFile.Name, 5) 'Fist
        'strMid = Format(Now(), "mm") ' Middle
        'strExt = Mid(objFile.Name, 8, 50) ' Last
        strName = Replace(Find(".", A2, 6), " " & Format(Now(), "ddmmyyyy") & ".")

        strNewFileName = strName & strMid & strExt 'build the string file name (can be done below as well)
        objFile.Copy strDestFolder & strNewFileName, False 'False = do not overwrite/ True = Overwrite if exist
         'End If 'where conditional check, if applicable would be placed.
        Counter = Counter + 1
    Next objFile 'go to the next file
    MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
    " copied to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!"
    Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
    Exit Sub
     'Message to alert if Source folder has no files in it to copy
    MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
    strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
    Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
    Application.ScreenUpdating = True 'turn screenupdating back on
    Application.EnableEvents = True 'turn events back on
    Exit Sub
     'A general error message
    MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
    "Please verify that all files in the folder are not currently open," & _
    "and the source directory is available"
    Err.Clear 'clear the error
    Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects
    Application.ScreenUpdating = True
    End Sub


Well-known Member
Apr 6, 2006
Stop looking folks have resolved the problem.

Public Sub InstrTest()

Dim fn1, fn2, fn2a, fn2b As String
Dim nL As Integer
'Filename to be repalced by variable
fn1 = "2.2 Hazard Assesment Form.docx"
'InStrRev counts from the right
nL = InStrRev(fn1, ".")
'selects all the filename characters less Ext
fn2 = Left(fn1, nL - 1)
'adds the date on the end
fn2 = fn2 & " " & Format(Now(), "ddmmyyyy")
'adds the Ext to it
fn2 = fn2 & Right(fn1, Len(fn1) - nL + 1)

'Check to see macro works
MsgBox "Filename Output =  " & fn2

'Macro needs to be combined now

End Sub

Forum statistics

Latest member

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...