パスを選択するようにユーザに問い合わせ

Question

私は、フォルダの内容（他のフォルダのみ）を読み取り、それらを特定の範囲のExcelにリストするコードを持っています。
問題は、コードが内容を読み取るパス（/ CtrExtrase）がコード内に指定されていることです。

ユーザーが選択するパスが必要です。完全に試して失敗しました。

マイコード：

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 

「私はパスを選択するようにユーザーに必要があるとして、これは、問題です：

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

使用FileDialogFolderPickerで、ここでは、関数内でラップです：

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 & "\")のデフォルトのパスを設定することができます：

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