Loop Finds First File and Stops

[NorthbyNorthwest]

Hi, everyone. Trying to get code to copy multiple (about 20 workbooks) from folder with a great many subfolders. Code below stops after first folder is found and copied. Could you anyone tell why it does not continue to identify other files?

Sub CopyFilesFromSubfolders()

Dim FSO As Object, fld As Object

Dim fsoFile As Object

Dim fsoFol As Object

 

sourcePath = "H:\QA\Monthly Quality Review\FY22 SQCRs\"

targetPath = "H:\QA\QA Management\FY2022 Audits and Reports\Monthly Combine\"

 

If Right(sourcePath, 1) <> "\" Then

    sourcePath = sourcePath & "\"

End If

 

Set FSO = CreateObject("Scripting.FileSystemObject")

Set fld = FSO.GetFolder(sourcePath)

 

If FSO.FolderExists(fld) Then

    For Each fsoFol In FSO.GetFolder(sourcePath).Subfolders

        For Each fsoFile In fsoFol.Files

            If Right(fsoFile, 4) = "xlsm" Then

                fsoFile.Copy targetPath

            End If

        Next

    Next

End If

End Sub

 

[GWteB]

Recursion is the answer for your issue.
Try this

Sub CopyFilesFromSubfolders(ByVal argSourcePath As String, ByVal argDestinationPath As String)

    Dim FSO As Object, fld As Object
    Dim fsoFile As Object
    Dim fsoFol As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(argSourcePath)

    If FSO.FolderExists(fld) Then
        For Each fsoFol In fld.Subfolders
            Debug.Print fsoFol.Path
            CopyFilesFromSubfolders fsoFol.Path, argDestinationPath
            For Each fsoFile In fsoFol.Files
                If Right(fsoFile, 4) = "xlsm" Then
                    fsoFile.Copy argDestinationPath
                End If
            Next
        Next
    End If
End Sub

Usage example:

Sub NorthbyNorthwest()
    Dim SourcePath As String, TargetPath As String
    
    SourcePath = "H:\QA\Monthly Quality Review\FY22 SQCRs\"
    TargetPath = "H:\QA\QA Management\FY2022 Audits and Reports\Monthly Combine\"

    If Right(SourcePath, 1) <> "\" Then
        SourcePath = SourcePath & "\"
    End If
    CopyFilesFromSubfolders SourcePath, TargetPath
    
End Sub

 

[NorthbyNorthwest]

Recursion is the answer for your issue.
Try this

Sub CopyFilesFromSubfolders(ByVal argSourcePath As String, ByVal argDestinationPath As String)

    Dim FSO As Object, fld As Object
    Dim fsoFile As Object
    Dim fsoFol As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(argSourcePath)

    If FSO.FolderExists(fld) Then
        For Each fsoFol In fld.Subfolders
            Debug.Print fsoFol.Path
            CopyFilesFromSubfolders fsoFol.Path, argDestinationPath
            For Each fsoFile In fsoFol.Files
                If Right(fsoFile, 4) = "xlsm" Then
                    fsoFile.Copy argDestinationPath
                End If
            Next
        Next
    End If
End Sub

Usage example:

Sub NorthbyNorthwest()
    Dim SourcePath As String, TargetPath As String
   
    SourcePath = "H:\QA\Monthly Quality Review\FY22 SQCRs\"
    TargetPath = "H:\QA\QA Management\FY2022 Audits and Reports\Monthly Combine\"

    If Right(SourcePath, 1) <> "\" Then
        SourcePath = SourcePath & "\"
    End If
    CopyFilesFromSubfolders SourcePath, TargetPath
   
End Sub

Thank you so much, GWteB. Worked perfectly. I never would have resolved this on my own. Recursion is something I am unfamiliar with. I looked up recursion and found the following definition: Recursion is the 'self-calling' of a VBA procedure (macro or function). With recursion you can run through a large number of loops by letting the macro call itself at all times. Still very much a learner when it comes to VBA. I have another question about better targeting this code. As the months go on, the number of files the code returns will grow, with not all needed. My original plan was to delete out the older files I do not need. However, I ran across this code from Ron DeBruin that would allow me to limit files to those updated in last 30 days. See code below. Could you help me by incorporating it into your code?

Sub Copy_Files_Dates()
'This example copy all files between certain dates from FromPath to ToPath.
'You can also use this to copy the files from the last ? days
'If Fdate >= Date - 30 Then
'Note: If the files in ToPath already exist it will overwrite
'existing files in this folder
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim Fdate As Date
    Dim FileInFromFolder As Object

    FromPath = "C:\Users\Ron\Data"  '<< Change
    ToPath = "C:\Users\Ron\Test"    '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    If Right(ToPath, 1) <> "\" Then
        ToPath = ToPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    For Each FileInFromFolder In FSO.getfolder(FromPath).Files
        Fdate = Int(FileInFromFolder.DateLastModified)
        'Copy files from 1-Oct-2006 to 1-Nov-2006
        If Fdate >= DateSerial(2006, 10, 1) And Fdate <= DateSerial(2006, 11, 1) Then
            FileInFromFolder.Copy ToPath
        End If
    Next FileInFromFolder

    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub

 

[JEC]

This could work as well, the wscript object gets all xls* files in all folders and subfolders at once.

Sub jec()
a = Split(CreateObject("wscript.shell").exec("cmd /c dir ""H:\QA\Monthly Quality Review\FY22 SQCRs\*.xls"" /b/s").stdout.readall, vbCrLf)
 For i = 0 To UBound(a)
   Name a(i) As "H:\QA\QA Management\FY2022 Audits and Reports\Monthly Combine\" & Split(a(i), "\")(UBound(Split(a(i), "\")))
 Next
End Sub

 

[GWteB]

code that would allow me to limit files to those updated in last 30 days. See code below. Could you help me by incorporating it into your code?

The code below is able to perform the way you want. When the argLastModifiedInDays parameter is set to 0 (zero) the DateLastModified property of each file is ignored, which means that any file that meets the file specification will be copied. See if this works for you.

Public Sub CopyFilesFromSubfolders(ByVal argSourcePath As String, ByVal argDestinationPath As String, _
                                   ByVal argFileSpec As String, ByVal argLastModifiedInDays As Long)

    Dim FSO As Object, oRoot As Object, oFile As Object, oFolder As Object, FileDate As Date

    argSourcePath = IIf(Right(argSourcePath, 1) = "\", argSourcePath, argSourcePath & "\")
    argDestinationPath = IIf(Right(argDestinationPath, 1) = "\", argDestinationPath, argDestinationPath & "\")
    argFileSpec = IIf(Len(argFileSpec) > 0, argFileSpec, "*.*")
    argLastModifiedInDays = IIf(argLastModifiedInDays > 0, argLastModifiedInDays, Date)

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(argSourcePath) And FSO.FolderExists(argDestinationPath) Then
        Set oRoot = FSO.getfolder(argSourcePath)
        For Each oFile In oRoot.Files
            If oFile.Name Like argFileSpec Then
                FileDate = VBA.Int(oFile.DateLastModified)
                If FileDate >= Date - argLastModifiedInDays Then
                    oFile.Copy argDestinationPath
                End If
            End If
        Next oFile
        DoEvents
        For Each oFolder In oRoot.SubFolders
            CopyFilesFromSubfolders oFolder.Path, argDestinationPath, argFileSpec, argLastModifiedInDays
        Next oFolder
    End If
End Sub

Usage example:

Sub NorthbyNorthwest()

    Dim SourcePath As String, TargetPath As String

    SourcePath = "H:\QA\Monthly Quality Review\FY22 SQCRs\"
    TargetPath = "H:\QA\QA Management\FY2022 Audits and Reports\Monthly Combine\"

    ' copy all files (from source folder & and all subfolders to target folder); existing files with duplicate names will be overwritten
    CopyFilesFromSubfolders SourcePath, TargetPath, "*.*", 0

    ' copy only those XLSM files which were updated within the last 30 days; existing files with duplicate names will be overwritten
    CopyFilesFromSubfolders SourcePath, TargetPath, "*.xlsm", 30
   
End Sub

 

[NorthbyNorthwest]

The code below is able to perform the way you want. When the argLastModifiedInDays parameter is set to 0 (zero) the DateLastModified property of each file is ignored, which means that any file that meets the file specification will be copied. See if this works for you.

Public Sub CopyFilesFromSubfolders(ByVal argSourcePath As String, ByVal argDestinationPath As String, _
                                   ByVal argFileSpec As String, ByVal argLastModifiedInDays As Long)

    Dim FSO As Object, oRoot As Object, oFile As Object, oFolder As Object, FileDate As Date

    argSourcePath = IIf(Right(argSourcePath, 1) = "\", argSourcePath, argSourcePath & "\")
    argDestinationPath = IIf(Right(argDestinationPath, 1) = "\", argDestinationPath, argDestinationPath & "\")
    argFileSpec = IIf(Len(argFileSpec) > 0, argFileSpec, "*.*")
    argLastModifiedInDays = IIf(argLastModifiedInDays > 0, argLastModifiedInDays, Date)

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(argSourcePath) And FSO.FolderExists(argDestinationPath) Then
        Set oRoot = FSO.getfolder(argSourcePath)
        For Each oFile In oRoot.Files
            If oFile.Name Like argFileSpec Then
                FileDate = VBA.Int(oFile.DateLastModified)
                If FileDate >= Date - argLastModifiedInDays Then
                    oFile.Copy argDestinationPath
                End If
            End If
        Next oFile
        DoEvents
        For Each oFolder In oRoot.SubFolders
            CopyFilesFromSubfolders oFolder.Path, argDestinationPath, argFileSpec, argLastModifiedInDays
        Next oFolder
    End If
End Sub

Usage example:

Sub NorthbyNorthwest()

    Dim SourcePath As String, TargetPath As String

    SourcePath = "H:\QA\Monthly Quality Review\FY22 SQCRs\"
    TargetPath = "H:\QA\QA Management\FY2022 Audits and Reports\Monthly Combine\"

    ' copy all files (from source folder & and all subfolders to target folder); existing files with duplicate names will be overwritten
    CopyFilesFromSubfolders SourcePath, TargetPath, "*.*", 0

    ' copy only those XLSM files which were updated within the last 30 days; existing files with duplicate names will be overwritten
    CopyFilesFromSubfolders SourcePath, TargetPath, "*.xlsm", 30
  
End Sub

 

[NorthbyNorthwest]

Thank you again, GWteB. You've made not just my day but my week! This forum has been very, very good to me. Appreciate all who share their know-how, time, and attention.

 

[GWteB]

You're welcome and thanks for the feedback