Copying Files from Subfolders Using VBA

Question

I'm trying to create a vba macro which will copy all excel files in the source folder which contains several sub folders. These files will need to be copied into one destination folder (without sub folders).

So far I have managed to copy the entire folder including the sub folders to the destination folder. How can I edit my code so that it only copies .xls files and pastes them without sub folders.

Sub PerformCopy()
==================== call ================================
MkDir "DestinationPath"

CopyFiles "Source Path With All Subfolders" & "\", "DestinationPath" & "\"

==================== Copy sub ===========================
End Sub


Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String)
Dim FSO As Object
Dim FileInFromFolder As Object
Dim FolderInFromFolder As Object
Dim Fdate As Long
Dim intSubFolderStartPos As Long
Dim strFolderName As String

Set FSO = CreateObject("scripting.filesystemobject")
'First loop through files
    For Each FileInFromFolder In FSO.GetFolder(strPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'If Fdate >= Date - 1 Then
            FileInFromFolder.Copy strTarget
        'end if
    Next

    'Next loop throug folders
    For Each FolderInFromFolder In FSO.GetFolder(strPath).SubFolders
        'intSubFolderStartPos = InStr(1, FolderInFromFolder.Path, strPath)
        'If intSubFolderStartPos = 1 Then

        strFolderName = Right(FolderInFromFolder.PATH, Len(FolderInFromFolder.PATH) - Len(strPath))
        MkDir strTarget & "\" & strFolderName

        CopyFiles FolderInFromFolder.PATH & "\", strTarget & "\" & strFolderName & "\"

    Next 'Folder

End Sub

Xabier Xabier · Accepted Answer · 2018-07-09T10:35:13

How about something like below, it uses your initial loop within your Folder loop to iterate through each file and copy into your destination folder:

Sub PerformCopy()
'==================== call ================================
'MkDir "DestinationPath"

CopyFiles "Source Path With All Subfolders" & "\", "DestinationPath" & "\"

'==================== Copy sub ===========================
End Sub


Public Sub CopyFiles(ByVal strPath As String, ByVal strTarget As String)
Dim FSO As Object
Dim FileInFromFolder As Object
Dim FolderInFromFolder As Object
Dim Fdate As Long
Dim intSubFolderStartPos As Long
Dim strFolderName As String

Set FSO = CreateObject("scripting.filesystemobject")
'First loop through files
    For Each FileInFromFolder In FSO.GetFolder(strPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
            FileInFromFolder.Copy strTarget
    Next

    'Next loop throug folders
    For Each FolderInFromFolder In FSO.GetFolder(strPath).SubFolders
            For Each FileInFromFolder In FSO.GetFolder(FolderInFromFolder).Files
                    FileInFromFolder.Copy strTarget
            Next
    Next

End Sub

Copying Files from Subfolders Using VBA

1 Answers