CopyFolder, если папка не существует с подстановочным знаком

Question

У меня есть макрос, который отправляет одну или несколько папок на основе имени с подстановочным знаком в целевую папку. Я пытаюсь заставить его пропустить копирование, если папка уже существует в папке назначения, но если я установлю ее на False, она прекратит копирование после нее. Если я пытаюсь сделать это с помощью Dir (vbDirectory), он возвращает только первую папку с именем внутри. FolderExists также возвращает только первое совпадение. Я также попытался изменить расположение строки CopyFolder, но безуспешно.

В этот момент макрос всегда копирует все папки с именем внутри.

    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

Чтобы иметь возможность копировать только папки, которые еще не находятся в месте назначения, вам необходимо составить список папок как в месте назначения, так и в исходном каталоге.

Затем перед копированием папки из источник, мы бы проверили, если папка уже существует в месте назначения. Для этого я бы предложил использовать словари, поскольку это облегчит задачу, поскольку у нас уже есть метод .Exists, и мы сможем использовать имя папки в качестве ключа для доступа к значению, которое будет путем к папке.

Чтобы создать эти словари, вы можете использовать следующую функцию:

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

Имеет пример, вы можете использовать функцию выше, как это:

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

Исходя из фрагмента кода в вашем вопросе, после реализации этого подхода ваш код будет выглядеть следующим образом:

    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