VBA - Iteration to copy & rename files in to a new folder

lionelnz

Well-known Member
Joined
Apr 6, 2006
Messages
568
Good morning from NZ. I posted a question on this yesterday to do renaming/appending filename. I solved that.

The problem I now have is that the code is not copying and renaming files to the new folder and yet when I run to cursor past the filenaming iteration it appears to be doing that. Comes with the Error Handler code of 52 asking to make sure that files are not open or in use. Here is my full code hopefully with enough comments to understand the process.
I have bolded the possible offending code.
TIA.

(This is for approximately 30 files of multiple types/Ext and looking to do this 2 to 3 times a week to individual folders with specific dates for the files in that folder.)

Code:
Sub Copy_and_Rename_To_New_Folder_LH()
'Modified 24/11/15
'For H&S
     
    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
    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
     
   [B] For Each objFile In objFolder.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)

         
        objFile.Copy strDestFolder & fn2, 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[/B]
    
    
     
    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
 

lionelnz

Well-known Member
Joined
Apr 6, 2006
Messages
568
Solved this. Code for iteration of renaming files in destination folder in blue & bolded

Code:
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
    
   [COLOR=#0000cd][B] 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[/B][/COLOR]
    
    
     
   ' 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
 

Forum statistics

Threads
1,082,044
Messages
5,362,847
Members
400,694
Latest member
Ave663

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...
Top