CopyFolder if folder does not exist with wildcard

Question

I have a macro that seaches one or multiple folders based on a name with wildcard to a destination folder. I'm trying to get it to skip the copying if the folder already exists in the destination folder but if I set it to False it will stop copying after it. If I try to do it with the Dir( vbDirectory), it only returns the first folder with the Name inside. The FolderExists also returns only the first match. I also tried to change the location of the CopyFolder line but no luck here.

At this moment, the macro always copies all the folders with the name inside.

    On Error Resume Next
    For Each f In fsFD.SubFolders
        n = n + 1
        ReDim Preserve vR(1 To n)
        With f
            vR(n) = f.Path
           'Debug.Print vR(n)
           FS.CopyFolder vR(n) & "/" & Name & "\Lay\*" & Wb.Sheets("Sheet3").Range("B1") & "*", MAIN_FOLDER & "\Lay\Lay\", False


        'FolderName = Dir(vR(n) & "/" & Name & "\Lay\*" & Wb.Sheets("Sheet3").Range("B1") & "*", vbDirectory)
  ' Debug.Print FolderName

        End With

        'Debug.Print FS.FolderExists(MAIN_FOLDER & "\Lay\Lay\*" & Wb.Sheets("Sheet3").Range("B1") & "*")




   'FS.CopyFolder vR(n) & "/" & Name & "\Lay\*" & Wb.Sheets("Sheet3").Range("B1") & "*", MAIN_FOLDER & "\Lay\Lay\"


    Next f

Answer 1

To be able to copy only the folders that are not already in the destination, you'll need to make a list of folders in both the destination and the source directory.

Then before copying the folder from the source, we would check if the folder already existing in the destination. To do that I would suggest using dictionaries since it will make things easier since we already have a .Exists method available and we will be able to use the folder name as a key to access the value which will be the path of the folder.

To create those dictionaries, you could use the following function:

Function GetFoldersDict(ByVal QueryFolderPath As String) As Object
'PURPOSE: Return a dictionary with all the folders inside the supplied folder (supports wildcards)
'key = folder name
'value = folder path

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject

    Dim FolderPath As String
    If InStr(QueryFolderPath, "*") > 0 Or InStr(QueryFolderPath, "?") > 0 Then
        'If the query contains a wildcard, we take everything before the last "\"
        FolderPath = Left$(QueryFolderPath, InStrRev(QueryFolderPath, "\")-1)
    Else
        'Make sure the QueryFolderPath has an ending "\" (this is important when we get to the Dir Function
        QueryFolderPath = IIf(Right$(QueryFolderPath, 1) <> "\", QueryFolderPath & "\", QueryFolderPath)
        FolderPath = Left$(QueryFolderPath, Len(QueryFolderPath) - 1)
    End If

    Dim TempDict As Scripting.Dictionary
    Set TempDict = New Scripting.Dictionary

    Dim ItemKey As String
    ItemKey = Dir(QueryFolderPath, vbDirectory)

    Do While ItemKey <> vbNullString

        Do While (ItemKey = "." Or ItemKey = "..")
            ItemKey = Dir(, vbDirectory)
        Loop

        If fso.FolderExists(FolderPath & "\" & ItemKey) Then
            TempDict.Add ItemKey, FolderPath & "\" & ItemKey
        End If

        ItemKey = Dir(, vbDirectory)

    Loop

    Set GetFoldersDict = TempDict

End Function

Has an example, you could make use of the function above like this:

Sub CopyNonExistingFolders()

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject

    Dim SourcePath As String
    SourcePath = "C:\Your\Path\source\*" 'Can include a wildcard
    Dim DestinationPath As String
    DestinationPath = "C:\Your\Path\destination"

    Dim SourceFolders As Scripting.Dictionary, DestinationFolders As Scripting.Dictionary
    Set SourceFolders = GetFoldersDict(SourcePath)
    Set DestinationFolders = GetFoldersDict(DestinationPath)

    Dim k As Variant
    For Each k In SourceFolders.Keys
        If Not DestinationFolders.Exists(k) Then
            fso.CopyFolder SourceFolders.Item(k), DestinationPath & "\", False
        End If
    Next k

End Sub

And base on the snippet of code in your question, the following would be what your code would look like after implementing this approach:

    On Error Resume Next
    For Each f In fsFD.SubFolders
        n = n + 1
        ReDim Preserve vR(1 To n)
        With f
            vR(n) = f.Path
           'Debug.Print vR(n)

        Dim SourcePath As String
        SourcePath = vR(n) & "/" & Name & "\Lay\*" & Wb.Sheets("Sheet3").Range("B1") & "*"
        Dim DestinationPath As String
        DestinationPath = MAIN_FOLDER & "\Lay\Lay"

        Dim SourceFolders As Scripting.Dictionary, DestinationFolders As Scripting.Dictionary
        Set SourceFolders = GetFoldersDict(SourcePath)
        Set DestinationFolders = GetFoldersDict(DestinationPath)

        Dim k As Variant
        For Each k In SourceFolders.Keys
            If Not DestinationFolders.Exists(k) Then
                FS.CopyFolder SourceFolders.Item(k), DestinationPath & "\", False
            End If
        Next k


        'FolderName = Dir(vR(n) & "/" & Name & "\Lay\*" & Wb.Sheets("Sheet3").Range("B1") & "*", vbDirectory)
  ' Debug.Print FolderName

        End With

        'Debug.Print FS.FolderExists(MAIN_FOLDER & "\Lay\Lay\*" & Wb.Sheets("Sheet3").Range("B1") & "*")




   'FS.CopyFolder vR(n) & "/" & Name & "\Lay\*" & Wb.Sheets("Sheet3").Range("B1") & "*", MAIN_FOLDER & "\Lay\Lay\"


    Next f