根据给出字符查找包含该字符的文件夹并输出路径

jave000

查看了遍历FSO的代码，试运行后发现有一个新的问题，因为我们项目文件夹太乱了，很难得到想要的结果，想问一下已知一个根目录，能否根据给出的关键词，输出该关键词所在的文件夹对应的路径？
比如我项目网盘上有许多文件夹，里面有很多子文件夹以及更多的子文件夹，现在我只想输出所有含有output的文件夹对应的路径，output不一定是完整文件夹名。其他的文件夹路径我都不要。

临沂-枸杞

FSO遍历下主文件夹,把所有文件路径取出来放数组里,然后再查找匹配

jave000

临沂-枸杞 发表于 2021-9-28 11:50
FSO遍历下主文件夹,把所有文件路径取出来放数组里,然后再查找匹配

谢谢，我查查学习一下

jave000

Sub Button_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.getfolder("\\caojsvr5.ad.glpoly.net\PUR_SIB\" & "\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\Logistic\" & "\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\MDI\C1\" & "\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\MDI\C2\" & "\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\PUR\" & "\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\TDI\C1\Under_Working\" & "\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\TDI\C2\")
    ActiveSheet.UsedRange.ClearContents
    a = 1
    For Each fd In ff.subfolders
        Cells(a, 1) = fd.Name
        Cells(a, 2) = fd
        a = a + 1
    Next fd
    Application.ScreenUpdating = True
End Sub

多个路径好像不行，因为我不是需要所有路径，就没选大神帖子的所有子文件夹

3190496160

上传附件来看看吧，没有附件，说再多也没意义的

jave000

3190496160 发表于 2021-9-29 09:06
上传附件来看看吧，没有附件，说再多也没意义的

你好，没有附件，我是需要一个一键按钮遍历所有带有关键字的子文件夹路径列表

jave000

试了好多写法，还是不会做

jave000

百度了几天，论坛也搜了好多页，没有关于子文件夹关键词筛选并列表的代码可以借鉴……

jave000

Sub Button_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("scripting.filesystemobject")
    ActiveSheet.UsedRange.ClearContents

    Set f1 = fso.getfolder("\\caojsvr5.ad.glpoly.net\PUR_SIB\")
    a = 1
    For Each fd1 In f1.subfolders
        Cells(a, 1) = fd1
        a = a + 1
    Next fd1

    Set f2 = fso.getfolder("\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\Logistic\")
    b = a
    For Each fd2 In f2.subfolders
        Cells(b, 1) = fd2
        b = b + 1
    Next fd2

    Set f3 = fso.getfolder("\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\MDI\C1\")
    c = b
    For Each fd3 In f3.subfolders
        Cells(c, 1) = fd3
        c = c + 1
    Next fd3

    Set f4 = fso.getfolder("\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\MDI\C2\")
    d = c
    For Each fd4 In f4.subfolders
        Cells(d, 1) = fd4
        d = d + 1
    Next fd4

    Set f5 = fso.getfolder("\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\PUR\")
    e = d
    For Each fd5 In f5.subfolders
        Cells(e, 1) = fd5
        e = e + 1
    Next fd5

    Set f6 = fso.getfolder("\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\TDI\C1\Under_Working\")
    f = e
    For Each fd6 In f6.subfolders
        Cells(f, 1) = fd6
        f = f + 1
    Next fd6

    Set f7 = fso.getfolder("\\caojsvr5.ad.glpoly.net\PUR_SIB\PUR_MOC\TDI\C2\")
    g = f
    For Each fd7 In f7.subfolders
        Cells(g, 1) = fd7
        g = g + 1
    Next fd7

    Dim h
        For h = 1 To 10000
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(h, 1), Address:=Cells(h, 1).Value
        Next

    Application.ScreenUpdating = True
End Sub







瞎写了这个，七个路径都只查子目录，可以运行。但是特别卡，还是希望能有大神帮忙提供一个可以通过关键字“output”输出“\\caojsvr5.ad.glpoly.net\PUR_SIB\”目录下所有子文件夹路径的代码模板，我可以自己学习和改造，但我不会写

xiangbaoan

Sub 自行测试吧()
  Dim p As String, Fso As Object, ar(1 To 2345, 1 To 1) As String, n As Long
  Set Fso = CreateObject("Scripting.FileSystemObject")
  p = "\\caojsvr5.ad.glpoly.net\PUR_SIB\"
  GetFolders p, Fso, ar, n
  Range("A1").Resize(UBound(ar)) = ar
  Set Fso = Nothing
End Sub

Function GetFolders(pth As String, Fso As Object, ar, n As Long)
  Dim fld
  For Each fld In Fso.GetFolder(pth).SubFolders
    If fld.Name Like "*output*" Then
      n = n + 1
      ar(n, 1) = fld.Path
    End If
    GetFolders fld.Path, Fso, ar, n
  Next
End Function