Excel 通过引用一系列单元格提示用户输入源文件夹和目标文件夹-涉及数据传输

我有4列数据需要转换为文件夹和子文件夹列表。B列将是主文件夹的第一个列表，C列的每个条目将是一个子文件夹，并深入到B列对应文件夹中D列的子文件夹中

列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

在此方面的任何帮助都将不胜感激。

试试这个

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_文件夹-您可以更改和更新目标

这使用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

按对话框上的“OK”返回值-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")

---

感谢@Badja的超快响应。根据您的指示，我已经更新了前面附加的代码主体。你认为这是对的吗？修复“If DEST_FOLDER Then”下面的行-尝试一下，看看会发生什么=F8通过子ALSO，vba在打开SRC_FOLDER以输出为n的行上抛出警告错误：编译错误-变量未定义突出显示n@BADGA. 你，先生！你是个天才。这很有效。最后一个问题，Vba提示我选择文件而不是文件夹！。您认为我应该将这一行**msoFileDialogOpen**更改为仅限于选择文件夹的其他行吗？请尝试使用Application.FileDialogMSOFILEDIALOGFOLDERPICKER这是一个非常好的答案。对我的答案给予了更多的深度和洞察力。但愿我有时间去制定新的解决方案，而不是去解决用户自己的问题。AllowMultiSelect从我头上飞过。AllowMultiSelect在默认情况下为False，因此它不是必需的。我习惯于直截了当地说很多默认值，但你可以不说-@K.Dᴀᴠɪs，感谢您的见解。我很想了解你的代码的功能。你能帮我解决这个错误吗？编译错误：未定义子或函数promptFolderDlg@fahadmanzur确保将我提供的第二个代码块中的函数复制到模块中。这是一个功能，所以它需要位于您的子测试仪之外。。。结束，哇！它真的起作用了！你们帮了我一个大忙。这可能是我升职的一个主要因素。非常感谢你。