Rechercher un chemin de dossier basé sur une valeur de cellule avec une zone de liste déroulante

Question

J'ai un problème dans VBA, je veux obtenir le chemin d'accès d'un dossier basé sur une valeur de zone de liste déroulante.

Voir, j'ai une feuille Excel appelée « TAG » où dans sa première colonne j'ai beaucoup de valeurs, comme P36300000, C36300001, etc. (image ci-dessous)

J'ai créé une macro boucle dans la colonne de feuille et crée un dossier basé sur chaque valeur de cellule.

Le « P » signifie qu'il est l'élément principal , et le « C » signifie qu'il est juste un élément de ce article.

i.e., il crée le P36300000 dossier qui contient: 3C6300001, C36300002, C36300003, C36300004, C36300005, C36300006 et la P36300007 contient le C36300008.

Folder Lists

Chacun (dossier primaire et le composant) a obtenu un dossier DT, où un fichier Excel est situé. (Non revelant mais, au cas où)

Le chemin du composant doit être quelque chose comme H: \ Work \ projet \ 2017 \ A1 \ P36300000 \ C36300001

Et quelque chose primaire comme H: \ Work \ Project \ 2017 \ A1 \ P36300000

Mon code est quelque chose comme ceci, mais, il ne peut pas obtenir le dossier de composant, seulement le principal.

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 

Merci pour votre temps!

Answer 1

La raison pour laquelle vous ne trouvez pas le dossier C est que vous recherchez le dossier C au même niveau que le dossier P, alors que vous devriez rechercher un niveau plus profond. Voici à quoi devrait ressembler votre code pour trouver le dossier C. De plus, je quitterai la boucle For une fois que vous aurez trouvé ce que vous cherchez pour gagner du temps.

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 

MISE À JOUR J'ai ajouté la fonction extract_P_folder en fonction de votre commentaire à une réponse précédemment affichée. Cela retournera le dossier parent du chemin du fichier transmis.

Answer 2

si quelqu'un étudie à l'avenir ...

ce code commence à un répertoire choisi et produit un tableau contenant tous les fichiers dans tous les sous-répertoires de premier niveau.

chaque entrée du tableau contient le nom du fichier et son nom de répertoire parent

utilise le système CMD appel

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