查询用户selectpath

我有一个代码，读取一个文件夹的内容（只有其他文件夹），并将其列入一定范围内的Excel中。
问题是代码中读取内容的path（/ CtrExtrase）在代码中给出。

我需要用户selectpath。 完全尝试失败。

我的代码：

Sub distribuire_foldere() Dim objFSO As Object Dim objFolder As Object Dim objSubFolder As Object Dim i As Integer 'CLEARS ALL PREVIOUS CONTENT Sheets("DISTRIBUIRE foldere").Range("A2:A2000").ClearContents 'INSERTS IN CELL THE PATH WHERE THE SCRIPT IS READING Sheets("DISTRIBUIRE foldere").Range("$E$1").Value = ThisWorkbook.path & "\CtrExtrase" ' LISTS THE CONTENT OF THE CHOOSEN FOLDER Application.StatusBar = "" 'Create an instance of the FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'Get the folder object On Error GoTo nuexistafolderul 

“这是问题，因为我需要用户selectpath：

 Set objFolder = objFSO.GetFolder(Application.ThisWorkbook.path & "\CtrExtrase") i = 1 'loops through each folder in the directory and prints their names On Error GoTo handleCancel Application.EnableCancelKey = xlErrorHandler For Each objSubFolder In objFolder.subfolders Application.StatusBar = objSubFolder.path & " " & objSubFolder.Name 'OUTPUTS THE FOLDERS NAME Cells(i + 1, 1) = objSubFolder.Name i = i + 1 Next objSubFolder handleCancel: If Err = 18 Then MsgBox "Ai anulat procesul inainte de finalizare! Reia procedura!" nuexistafolderul: MsgBox "Nu exista folderul pentru extractia contractelor! Extrage intai contractele!" End If 'CALLS A MODULE THAT INSERTS CERTAIN TEXT INTO A BATCH FILE Call Module1.batchfile2 End Sub 

Answer 1

使用FileDialog和FolderPicker ，在这里它包装在一个函数中：

 Function GetFolder(Optional strPath As String = "C:\") As String Dim fldr As FileDialog Dim sItem As String GetFolder = vbNullString 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 

而你的代码，你可以在GetFolder(ThisWorkbook.Path & "\")设置默认path：

 Sub distribuire_foldere() Dim objFSO As Object Dim objFolder As Object Dim objSubFolder As Object Dim i As Integer 'CLEARS ALL PREVIOUS CONTENT Sheets("DISTRIBUIRE foldere").Range("A2:A2000").ClearContents 'INSERTS IN CELL THE PATH WHERE THE SCRIPT IS READING Sheets("DISTRIBUIRE foldere").Range("$E$1").Value = ThisWorkbook.Path & "\CtrExtrase" ' LISTS THE CONTENT OF THE CHOOSEN FOLDER Application.StatusBar = "" 'Create an instance of the FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'Get the folder object On Error GoTo nuexistafolderul 'THIS IS THE PROBLEM, AS I NEED THE USER TO CHOOSE THE PATH: Set objFolder = objFSO.GetFolder(GetFolder(ThisWorkbook.Path & "\")) i = 1 'loops through each folder in the directory and prints their names On Error GoTo handleCancel Application.EnableCancelKey = xlErrorHandler For Each objSubFolder In objFolder.SubFolders Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name 'OUTPUTS THE FOLDERS NAME Cells(i + 1, 1) = objSubFolder.Name i = i + 1 Next objSubFolder handleCancel: If Err = 18 Then MsgBox "Ai anulat procesul inainte de finalizare! Reia procedura!" nuexistafolderul: MsgBox "Nu exista folderul pentru extractia contractelor! Extrage intai contractele!" End If 'CALLS A MODULE THAT INSERTS CERTAIN TEXT INTO A BATCH FILE Call Module1.batchfile2 End Sub