Скопируйте несколько файлов в несколько папок, используя FileDialog в Excel vba

Question

Я пытаюсь собрать код VBA для копирования файлов из фиксированной папки в другую папку. Моя проблема в том, что я хочу указать, куда копировать файлы, используя "Application.FileDialog(msoFileDialogFolderPicker)", и я не знаю, как это сделать. Любая помощь будет оценена.

Sub Copy_Folder()

    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim F As Object
    Set F = Application.FileDialog(msoFileDialogFolderPicker)


    FromPath = "Z:\Templates\Template 2020"  
    ToPath = "C:\Users\ocosmele\Desktop\New folder"

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

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

    FSO.CopyFolder source:=FromPath, destination:=ToPath
    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath

End Sub

Answer 1

Только что скорректировал первую часть вашего кода. Пожалуйста, прочтите комментарии к коду и настройте его в соответствии со своими потребностями.

Option Explicit

Sub Copy_Folder()

    Dim fso As Object
    Dim targetFolder As Object

    Dim fromPath As String
    Dim intialPath As String
    Dim toPath As String

    ' Initialize the file system object
    Set fso = CreateObject("Scripting.FileSystemObject")

    fromPath = "C:\Temp\Test"
    intialPath = "C:\Users\ocosmele\Desktop\New folder"

    ' Ask user for the destination folder
    Set targetFolder = Application.fileDialog(msoFileDialogFolderPicker)

    ' Define the target folder dialog box properties and result
    With targetFolder
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = intialPath
        If .Show <> -1 Then
            MsgBox "You didn't select anything"
            Exit Sub
        End If
        toPath = .SelectedItems(1)
    End With

    If Right(fromPath, 1) = "\" Then
        fromPath = Left(fromPath, Len(fromPath) - 1)
    End If

    If Right(toPath, 1) = "\" Then
        toPath = Left(toPath, Len(toPath) - 1)
    End If


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

    fso.CopyFolder Source:=fromPath, Destination:=toPath

    MsgBox "You can find the files and subfolders from " & fromPath & " in " & toPath

End Sub

Дайте мне знать, если он работает.