使用组合框查找基于单元格值的文件夹路径

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