使用msoFileDialogFolderPicker获取文件夹路径

Question

我有一个代码，该代码从SourcePath中选择文件，然后将其重命名并保存在DestPath中。该代码可以与SourcePath的硬编码文件夹路径一起正常工作（SourcePath =“ C：\ Invoices \ Raw发票”）。但是，它无法使用msoFileDialogFolderPicker函数捕获和保留文件夹路径。该代码无法在sourcepath中找到该文件，并按编程给出错误。

这是示例数据。

这是我正在使用的代码。

Sub Rename_invoices()
    Dim SourcePath As String, DestPath As String, Fname As String, NewFName As String
    Dim i As Long
    SourcePath = GetFolder("C:\")
    DestPath = "C:\Dunning Temp\"
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        If Not IsEmpty(Range("A" & i).Value) Then
            NewFName = Range("B" & i).Value
            'Search for the first file containing the string in column A
            Fname = Dir(SourcePath & "*" & Range("A" & i).Value & "*")
            If Fname <> vbNullString Then
                FileCopy SourcePath & Fname, DestPath & NewFName
            Else
                MsgBox Range("A" & i).Value & " dosen't exist in the folder"
            End If
        End If
    Next i
    ActiveSheet.Close = False
End Sub

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

Answer 1

您的GetFolder函数返回的路径不会以反斜杠\结尾。照原样，您在Dir中传递给Fname = Dir(SourcePath & "*" & Range("A" & i).Value & "*")的 pathname 参数将是错误的。

因此，将SourcePath = GetFolder("C:\")更改为SourcePath = GetFolder("C:\") & "\"，或在GetFolder函数中添加尾随反斜杠。

正如@Mistella所指出的那样，使用Debug.Print可以很容易地突出显示此问题。