Locate Folder Path Based on a Cell Value with a Combo Box

问题

I have an issue in VBA, i want to get the path of a folder based on a combo box value.

See, i have an excel sheet called "TAG" where in his first column i have a lot of values, like P36300000, C36300001, etc. (Image Below)

I have created a macro that loops through the sheet column and creates a folder based on each cell value.

The "P" means that it's the Primary item, and the "C" means that it is just a component of that Item.

i.e, it creates the P36300000 folder which contains: 3C6300001, C36300002, C36300003, C36300004, C36300005, C36300006 and the P36300007 contains the C36300008.

Folder Lists

Each one (Primary Folder and the Component) got a DT Folder, where an excel file is located. (Not revelant but, just in case)

The path of the component should be something like H:\Work\Project\2017\A1\P36300000\C36300001

And the primary something like H:\Work\Project\2017\A1\P36300000

My code is something like this, but, it can't get the Component Folder, only the Primary one.

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

Thanks for your time!

回答1:

The reason you're not finding the C folder is because you're looking for the C folder at the same level as the P folder, when you should be looking a level deeper. Here's what your code should look like to find the C folder. Also, I would exit the For Loop once you find what you're looking for to save time.

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 I've added the extract_P_folder function based on your comment to a previously posted answer. This will return the parent folder of the passed in file path.

回答2:

if anyone is researching this in the future ...

this code starts at a chosen directory and produces an array containing all the files in all the first level subdirectories.

each array entry contains the filename and its parent directory name

uses system CMD call

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

来源：https://stackoverflow.com/questions/46857148/locate-folder-path-based-on-a-cell-value-with-a-combo-box