Запрашивать у пользователя исходную и целевую папку, ссылаясь на диапазон ячеек - включает передачу данных

Question

У меня есть 4 столбца данных, которые мне нужно преобразовать в список папок и подпапок. Столбец B будет первым списком основных папок, а каждая запись столбца C будет подпапкой и глубже в подпапку столбца D в соответствующей папке из столбца B.

Столбец A содержит имена файлов .pdf, хранящихся в исходных адресатах, которые необходимо перенести в последнюю подпапку целевого адресата.

Присутствует Источник и целевой каталог:

Source: C:\Users\Manzurfa\Desktop\Macro Project\Carlo Project\Order Confirmations
Target: C:\Users\Manzurfa\Desktop\Macros

Хотя приведенный ниже код работает исключительно хорошо, мне понадобится макрос, чтобы предложить пользователю указать исходную папку и целевую папку вместо принудительного принудительного использования каталогов.

Option Explicit

Sub Tester()    

'Const SRC_FOLDER = "C:\Users\Manzurfa\Desktop\Macro Project\Carlo Project\Order Confirmations\"
'Const DEST_FOLDER = "C:\Users\Manzurfa\Desktop\Macros\"

Dim Rng As Range, fPath, fName
Dim SRC_FOLDER As String, DEST_FOLDER As String
Dim maxRows As Long, maxCols As Long, r As Long, c As Long

Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count

With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
SRC_FOLDER = .SelectedItems(1)
End If
End With

If SRC_FOLDER <> "" Then
Open SRC_FOLDER For Output As #n
End If

'assuming the first row in ther selection is the headers...
'  otherwise, start at 1
For r = 2 To maxRows
    fPath = DEST_FOLDER '<<set starting point
    For c = 2 To maxCols
        fPath = fPath & "\" & Rng.Cells(r, c) '<<build next level
        If Len(Dir(fPath, vbDirectory)) = 0 Then MkDir fPath
 On Error Resume Next
    Next c
    'create file name
    fName = Right("0000000000" & Rng.Cells(r, 1).Value, 10) & ".pdf"
    'copy to fpath
    FileCopy SRC_FOLDER & fName, fPath & "\" & fName
Next r

  With Application.FileDialog(msoFileDialogOpen)
  .Show
  If .SelectedItems.Count = 1 Then
  DEST_FOLDER = .SelectedItems(1)
  End If
  End With

  If DEST_FOLDER <> "" Then
  Open DEST_FOLDER For Output As #n
  End If

  End Sub

Любая помощь в этом будет должным образом оценена.

Answer 1

При этом используется метод Application.FileDialog, и он будет повторяться до тех пор, пока не будет выбран правильный выбор, предлагая пользователю, если он нажмет на кнопку отмены в диалоговом окне, повторить попытку.

Кроме того, установка InitialFileName выберет начальную папку.

Dim sourcePath As String
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Title = "Source Directory"
    .InitialFileName = "C:\Users\"
    Do
        If .Show = -1 And .SelectedItems.Count > 0 Then
            sourcePath = .SelectedItems(1)
            Exit Do
        Else
            Select Case MsgBox("Please select a source directory!", vbAbortRetryIgnore + vbDefaultButton2)
            Case vbAbort
                Exit Sub
            Case vbIgnore
                Exit Do
            End Select
        End If
    Loop
End With

' . . . . 

Dim targetPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Title = "Target Directory"
    .InitialFileName = "C:\Users\"
    Do
        If .Show = -1 And .SelectedItems.Count > 0 Then
            targetPath = .SelectedItems(1)
            Exit Do
        Else
            Select Case MsgBox("Please select a source directory!", vbAbortRetryIgnore + vbDefaultButton2)
            Case vbAbort
                Exit Sub
            Case vbIgnore
                Exit Do
            End Select
        End If
    Loop
End With

Нажатие «ОК» в диалоговом окне возвращает значение -1, отсюда и If .Show = -1.

---

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

Function promptFolderDlg(Optional sTitle As String = "Select folder path") As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = sTitle
        .InitialFileName = "C:\Users\"
        Do
            If .Show = -1 And .SelectedItems.Count > 0 Then
                promptFolderDlg = .SelectedItems(1)
                Exit Function
            Else
                Select Case MsgBox("Please select a folder path!", vbAbortRetryIgnore + vbDefaultButton2)
                Case vbAbort
                    End
                Case vbIgnore
                    Exit Function
                End Select
            End If
        Loop
    End With

End Function

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

SRC_FOLDER = promptFolderDlg("Source Directory")

' . . .

fPath = promptFolderDlg("Target Directory")

Answer 2

Попробуйте это

Dim SRC_FOLDER As String, DEST_FOLDER as String

With Application.FileDialog(msoFileDialogOpen)
.Show
If .SelectedItems.Count = 1 Then
    SRC_FOLDER = .SelectedItems(1)
End If
End With

If SRC_FOLDER<> "" Then
    Open SRC_FOLDER For Output As #n
End If

Это только для SRC_FOLDER - вы можете изменить и обновить для Destination