使用組合框查找基於單元格值的文件夾路徑

Question

我在VBA中遇到問題，我想根據組合框值獲取文件夾的路徑。

看，我有稱爲「TAG」 Excel工作表，其中在他的第一列我有很多的值，像P36300000，C36300001等（圖像下方）

我已經創建了一個宏循環瀏覽表單欄並根據每個單元格值創建一個文件夾。

的「P」是指它的主項，而「C」意味着它是項目的只是一個組成部分。

即，它創建包含P36300000文件夾：3C6300001，C36300002，C36300003，C36300004，C36300005，C36300006和P36300007包含C36300008。

Folder Lists

每一個（主文件夾和組件）有一個DT文件夾，其中的Excel文件的位置。 （不revelant但是，以防萬一）

組件的路徑應該是這樣的 H：\工作\項目\ 2017年\ A1 \ P36300000 \ C36300001

和主像 H：\ Work \ Project \ 2017 \ A1 \ P36300000

我的代碼是這樣的，但它不能得到組件文件夾，只有主要的一個。

Option Explicit 

Private Sub btnPath_Click() 

    Dim MyValue As String 
    Dim subFldr As Object 
    Dim msg As String 
    Dim fldr As String 

    Worksheets("TAG").Visible = True 
    MyValue = cmbTAG.Value      ' Selected Value of the cmbBOX 

    fldr = ActiveWorkbook.Path & "\2017" 

    If (Left(cmbTAG.Value, 1) = "P") Then  ' If the Folder is Primary 

     fldr = ActiveWorkbook.Path & "\2017\A1" 

     If Dir(fldr, vbDirectory) <> "" Then 
      For Each subFldr In CreateObject("Scripting.FileSystemobject").GetFolder(fldr).Subfolders 
       If subFldr Like "*\" & MyValue Then msg = subFldr.Name 
      Next subFldr 

      txtRutaPadre.Text = fldr & "\" & msg 
      txtRutaDT.Text = fldr & "\" & msg & "\DT" 
     End If 

    ElseIf (Left(cmbTAG.Value, 1) = "C") Then ' if it is a Component. 

     fldr = ActiveWorkbook.Path & "\2017\A1" 

     If Dir(fldr, vbDirectory) <> "" Then 
      For Each subFldr In CreateObject("Scripting.FileSystemobject").GetFolder(fldr).Subfolders 
       If subFldr Like "*\" & MyValue Then msg = subFldr.Name 
      Next subFldr 

      txtPrimary.Text = fldr & "\" & msg 
      txtDT.Text = fldr & "\" & msg & "\DT" 
     End If 
    End If 
End Sub 

謝謝你的時間！

Answer 1

您找不到C文件夾的原因是因爲您正在尋找與P文件夾位於同一級別的C文件夾，因此您應該更深入地查看級別。這是你的代碼應該看起來像找到C文件夾。另外，一旦你找到你想要的東西來節省時間，我會退出For Loop。

Sub test() 
    Dim msg As String 
    Dim fldr As String 
    Dim MyValue As String 
    Dim subFldr As Object 
    Dim subsubFldr As Object 
    Dim pFolder As String 
    Dim cFolder As String 

    MyValue = Worksheets(1).Range("A1").Value      ' Selected Value of the cmbBOX 
    Debug.Print MyValue 
    fldr = "C:\Users\GAC-Phillip\Dropbox" 

    If Dir(fldr, vbDirectory) <> "" Then 
     For Each subFldr In CreateObject("Scripting.FileSystemobject").GetFolder(fldr).Subfolders 
      For Each subsubFldr In CreateObject("Scripting.FileSystemobject").GetFolder(subFldr).Subfolders 
       Debug.Print subsubFldr 
       If subsubFldr Like "*\" & MyValue Then 
        MsgBox ("found folder!" & vbNewLine & subsubFldr) 
        cFolder = subsubFldr.Path 
        GoTo FoundFolder 
       End If 
      Next subsubFldr 
     Next subFldr 
    End If 

FoundFolder: 
    pFolder = extract_P_folder(cFolder) 
    MsgBox (pFolder) 
End Sub 


Function extract_P_folder(ByRef filePath As String) As String 
    Dim TestArray() As String 
    TestArray = Split(filePath, "\") 
    extract_P_folder = TestArray(UBound(TestArray) - 1) 
    Debug.Print extract_P_folder ' for double checking in development 
End Function 

UPDATE 我已經添加基於對先前發佈的回答您的評論的extract_P_folder功能。這將返回傳入文件路徑的父文件夾。

Answer 2

如果有人正在研究此在未來...

這個代碼啓動在所選擇的目錄，並生成包含在所有的第一電平的子目錄中的所有文件的數組。

每個數組條目包含文件名和它的父目錄名

使用系統調用CMD

Option Explicit 

' this sub pulls a list of first level subdirectories in a particular directory 
' and returns an array containing the subdirectory name and a containing filename 
' returns one entry for each filename found inside the subdirectories 

Sub aaa() 
' Dim shel As WshShell   ' early binding, requires reference to "windows script host object model" 
    Dim shel As Object 
    Set shel = VBA.CreateObject("WScript.Shell") 

    Dim startDir As String 
    startDir = "C:\Users\xxxx\Desktop\excelWork" 

    Dim cmd As String 

    cmd = "cmd /c cd /D " & startDir _ 
     & " & " _ 
     & "@for /f ""tokens=1"" %a in ('dir . /a:d /b') " _ 
     & "do " _ 
     & "@for /f ""tokens=1"" %b in ('dir .\%a /a:-d /b') " _ 
     & "do " _ 
     & "@echo %a?%b" ' the question mark is a separator that will never be found in a microsoft filename 

     ' microsoft invalid filename characters \/:*?"<>| 

    Dim op As Variant 
    op = Split(shel.Exec(cmd).StdOut.ReadAll(), vbCrLf)  ' convert to array, one line per element 

    Dim numFiles As Integer 
    numFiles = UBound(op) 

    ReDim files(numFiles) As Variant 

    Dim i As Integer 
    For i = 0 To numFiles 
     files(i) = Split(op(i), "?")      ' split each line into parent directory and filename pair 
    Next i 

    MsgBox files(0)(0) & " --- " & files(0)(1)    ' print first entry 

End Sub