excel - 集成文件夹选择器

Question

我正在尝试将文件夹选择器而不是常量路径集成到我的代码中，但遇到了问题。当我尝试从开发人员那里运行代码时，文件夹选择器出现，但随后 excel 工作簿变为空白并且 Excel 没有关闭，但它停止工作。我引用了这个问题：Folder Picker Excel VBA & paste Path to Cell但我遇到了问题。这是我正在处理的代码：

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, sh As Worksheet
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Dim fileExplorer As FileDialog
    Dim folderPath As String
    Dim LogSheet As Worksheet
    
    Set fileExplorer = Application.FileDialog(msoFileDialogFolderPicker)

    'To allow or disable to multi select
    fileExplorer.AllowMultiSelect = False

    With fileExplorer
        If .Show = -1 Then 'Any folder is selected
            folderPath = .SelectedItems.Item(1)
        Else ' else dialog is cancelled
            MsgBox "You have cancelled the dialogue"
            folderPath = "" ' when cancelled set blank as file path.
        End If
        'Set strPath = .SelectedItems.Item(1)
        End With
            
    Set LogSheet = ThisWorkbook.Worksheets("Log")
    
    'Const strPath As String = "E:\\Desktop\Example\"
        'ChDir strPath
    strExtension = Dir(strPath & "*.xls*")
    
    Application.StatusBar = "Importing Data..."
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
    
    Do While strExtension <> ""
        path = strPath & strExtension
        If VerifyTasks(strPath & strExtension, wkbDest) Then
            LogSheet.Range("A" & LogSheet.Rows.Count).End(xlUp).Offset(1, 0).Value = strPath & strExtension & "  " & "Succeeded"
        Else
            LogSheet.Range("A" & LogSheet.Rows.Count).End(xlUp).Offset(1, 0).Value = strPath & strExtension & "  " & "Failed"
        End If
        On Error GoTo 0
        
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
    Application.StatusBar = False
MsgBox "Data imported, review Log sheet."

End Sub

Function VerifyTasks(path As String, ByRef wkbDest As Workbook) As Boolean
    On Error GoTo errorhandler:
    Set wkbSource = Workbooks.Open(path)
    With wkbSource
       'locate last row to start copying new value from the next spreadsheet
        LastRow = wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
        'From the Basis & Credits cell AB46, copy to last row+1 in the Master sheet starting in row A2
        .Sheets("Basis & Credits").Range("AB46").Copy
         wkbDest.Sheets("Master").Range("A" & LastRow).PasteSpecial Paste:=xlPasteValues
        .Close savechanges:=False
    End With
    VerifyTasks = True
    Exit Function
errorhandler:
    VerifyTasks = False
    wkbSource.Close savechanges:=False
End Function

任何帮助，将不胜感激。谢谢。

标签： excelvbafilepicker