VBA Marco To Copy Excel Files From Sub-Directory To Another Directory

**LalitPandey87** · 05-31-2013, 09:26 AM

Give a try to this code and change source and destination path accordingly:

Code:

Option Explicit
 
Sub Copy_Files_To_New_Folder()
     ''This procedure will copy/move all files in a folder to another specified folder'''
     ''Can be easily modified
     
    Dim objFSO As Object, objFolder As Object, PathExists As Boolean
    Dim objFile As Object, strSourceFolder As String, strDestFolder As String
    Dim x, Counter As Integer, Overwrite As String
     
    Application.ScreenUpdating = False 'turn screenupdating off
    Application.EnableEvents = False 'turn events off
     
     'identify path names below:
    strSourceFolder = "C:\MyFolder" 'Source path
    strDestFolder = "C:\Backup" 'destination path, does not have to exist prior to execution
     
     '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 = CreateObject("Scripting.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...
         
         If LCase(objFile.Type) Like LCase("Microsoft Office Excel*") Then
            objFile.Copy strDestFolder & "\" & objFile.Name 'Copy file
            Counter = Counter + 1 'increment a count of files copied
        End If
         
    Next objFile 'go to the next file
     
    MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
    " copied/moved 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 'exit sub here to avoid subsequent actions
     
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