Good morning all. Just posting a solution to my "Creating new folder, copying files to that folder and renaming files with various extensions (including variable extension lengths).

The reason I needed this is that I have 47 master files that have to go into a company file. This has to be done 2 to 3 times a week and ongoing for the foreseeable future. The 47 files have to be appended with the date in the format of "ddmmyyyy".

I have pinched and borrowed from several sources and hence a bit untidy. Love advice on how to tidy up.

Sub Copy_To_New_Folder_And_Rename_in_Folder_LH()
'Modified 25/11/15
'For H&S - Ant
'Copy to new folder & rename files in new folder
'Needs tidying up.
     
    Dim objFSO As FileSystemObject, objFolder, objDFolder As Folder, PathExists As Boolean
    Dim objFile As File, strSourceFolder, 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
    Dim fn1, fn2 As String
    Dim nL As Integer

     
    Application.ScreenUpdating = False 'turn screenupdating off
    Application.EnableEvents = False 'turn events off
    
         
    strSourceFolder = "U:\Ant\WSMP Supreme Manual Master 2015\" 'Source path
   
    val = Application.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...
         
                   
        objFile.Copy strDestFolder, 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
    
    Set objDFolder = objFSO.GetFolder(strDestFolder) 'get the destination folder
    
    If Not objDFolder.Files.Count > 0 Then GoTo NoFiles 'if no files exist in source folder "Go To" the NoFiles section
     
    For Each objFile In objDFolder.Files 'for every file in the folder...
          'Filename to be repalced by variable
            
            'InStrRev counts from the right
            nL = InStrRev(objFile, ".")
            'selects all the filename characters less Ext
            fn2 = Left(objFile, nL - 1)
            'adds the date on the end
            fn2 = fn2 & " " & Format(Now(), "ddmmyyyy")
            'adds the Ext to filename
            fn2 = fn2 & Right(objFile, Len(objFile) - nL + 1)
            'Need Name to assign new filename
            Name objFile As fn2
           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
     
NoFiles:
     '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
     
ErrHandler:
     '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 'turn screenupdating back on
    Application.EnableEvents = True 'turn events back on
End Sub