Question

我正在尝试重新编辑下面的VBA代码（完美工作），该代码将提示用户一个对话框来选择“源”文件夹，并提示另一个对话框来选择目标文件夹。任何帮助将不胜感激。

下面的代码在我自己的目录中可以很好地工作。但是，让其他用户可以灵活选择自己选择的文件夹，将是很棒的选择。

Option Explicit

**SRC_FOLDER = GetFolder()
DEST_FOLDER = GetFolder()**

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

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

'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

End Function

由于@Tim Williams，此代码非常有效我只希望此宏与其他用户更加友好

Answer 1

考虑：

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

我没有编写此代码。

它源自：

Ozgrid

和来自Mr Excel

EDIT＃1：

所以替换：

 Const DEST_FOLDER = "C:\Users\Manzurfa\Desktop\Macros"

具有：

 DEST_FOLDER = GetFolder()

等

（如果要生成完整的文件规范，请确保正确管理路径和文件名之间的反斜杠。）

VBA代码提示任何用户选择源文件夹和目标文件夹

1 个答案: