使用组合框根据单元格值定位文件夹路径

Question

我在 VBA 中遇到问题，我想根据组合框值获取文件夹的路径。

看，我有一个名为 "TAG" 的 excel sheet，在他的第一列中我有很多值，例如 P36300000、C36300001 等。 （下图）

我创建了一个循环遍历 sheet 列的宏，并根据每个单元格值创建了一个文件夹。

"P"表示它是主要项目，"C"表示它只是项目的一个组成部分.

即，它创建 P36300000 文件夹，其中包含：3C6300001、C36300002、C36300003、C36300004、C36300005、C36300006 和 P36300007 包含 C36300008.

Folder Lists

每个（主文件夹和组件）都有一个 DT 文件夹，其中有一个 excel 文件。（不相关，但以防万一）

组件的路径应该是这样的 H:\Work\Project17\A1\P36300000\C36300001

主要的类似 H:\Work\Project17\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 & "17"

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

        fldr = ActiveWorkbook.Path & "17\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 & "17\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 循环以节省时间。

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

更新我已根据您对先前发布的答案的评论添加了 extract_P_folder 功能。这将 return 传入文件路径的父文件夹。

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

使用组合框根据单元格值定位文件夹路径

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

excel

vba

userform