Board logo

標題: [發問] 請教如何列出所有的子資料夾名 [打印本頁]
作者: 巴克斯    時間: 2015-12-17 12:19     標題: 請教如何列出所有的子資料夾名

想要將指定資料夾內的所有子資料夾及檔名列出
目前可以將檔案列出了,可是不會列出所有的子資料夾名
細部說明及檔案於附檔中

求助是否可達成此功能?
感謝幫忙:loveliness:
作者: stillfish00    時間: 2015-12-17 14:27

回復 1# 巴克斯
  1. Sub 列出明細2()
  2.     [B1] = ActiveWorkbook.Path
  3.     Range([a4], [f65536]).ClearContents
  4.     Range([a4], [f65536]).Interior.ColorIndex = xlNone

  6.     Dim fs, fd
  7.     Set fs = CreateObject("Scripting.FileSystemObject")
  8.     Set fd = fs.GetFolder([B1].Value)
  9.    
  10.     FilesHierarchy fd, "x"
  11. End Sub

  13. Sub FilesHierarchy(fd, hierarchy As String)
  14.     Dim i As Long
  15.     With fd
  16.         Cells(Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(1, 4) = Array(hierarchy, .Name, .ParentFolder.Path, "資料夾")
  17.         For Each x In .SubFolders
  18.             i = i + 1
  19.             FilesHierarchy x, hierarchy & "." & i   'recursive call
  20.         Next
  21.         For Each x In .Files
  22.             i = i + 1
  23.             Cells(Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(1, 4) = Array(hierarchy & "." & i, x.Name, .Path, "檔案")
  24.         Next
  25.     End With
  26. End Sub
複製代碼
作者: 巴克斯    時間: 2015-12-17 17:11

回復 1# 巴克斯
感謝stillfish00
很精簡的程式就解決問題了

我繼續想做樹狀圖的部分
後續有部分不會想再請協助完成
也更想看看會以哪種精練的程式可以達成
細項說明請看附件

謝謝
作者: stillfish00    時間: 2015-12-17 19:35

回復 3# 巴克斯
  1. Dim cOffset As Long
  2. For r = 4 To [a65536].End(3).Row
  3.     cOffset = UBound(Split(Cells(r, 1), "."))
  4.     With Cells(r, 8 + cOffset)
  5.         .Value = Cells(r, 3)
  6.         .Interior.ColorIndex = IIf(Cells(r, 2) = "資料夾", 36, xlNone)
  7.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  8.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  9.     End With
  10.     For c = 9 To 8 + cOffset - 1
  11.         Cells(r, c).Borders(xlEdgeLeft).LineStyle = xlContinuous
  12.     Next
  13. Next
  14. Application.ScreenUpdating = True
複製代碼
作者: 巴克斯    時間: 2015-12-18 09:09

回復 4# stillfish00
感謝stillfish00

樹狀線補足ok了
不過有部分線多出來

想不出有效的方法去除
再討教(如附件),感謝
作者: stillfish00    時間: 2015-12-18 11:10

回復 5# 巴克斯
  1. Sub 列出明細()
  2. [b1] = ActiveWorkbook.Path
  3. Range([a4], [f65536]).ClearContents
  4. [a4:a65536].EntireRow.Delete
  5. Application.ScreenUpdating = False

  7. Dim fs, fd
  8. Set fs = CreateObject("Scripting.FileSystemObject")
  9. Set fd = fs.GetFolder([b1].Value)  '根目錄
  10.    
  11. FilesHierarchy fd, "x"
  12. Range([a4], Cells([a65536].End(3).Row, 6)).Borders.LineStyle = 1
  13. Range([a4], [a65536].End(3)).RowHeight = 24

  15. Dim cOffset As Long, ar
  16. For r = 4 To [a65536].End(3).Row     '作樹狀圖
  17.     ar = Split(Cells(r, 1), ".")
  18.     cOffset = UBound(ar)  '階層數
  19.     With Cells(r, 8 + cOffset)
  20.         .Value = Cells(r, 3)
  21.         .Interior.ColorIndex = IIf(Cells(r, 2) = "資料夾", 36, xlNone)
  22.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  23.         .Borders(xlEdgeBottom).Weight = xlThick
  24.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  25.     End With
  26.    
  27.     If ar(cOffset) <> "x" And ar(cOffset) <> "1" Then
  28.         For i = r - 1 To 4 Step -1
  29.             If Cells(i, 8 + cOffset) <> "" Then Exit For
  30.             Cells(i, 8 + cOffset).Borders(xlEdgeLeft).LineStyle = xlContinuous
  31.         Next
  32.     End If
  33.    
  34. Next
  35. Application.ScreenUpdating = True
  36. End Sub
複製代碼
作者: 巴克斯    時間: 2015-12-18 17:05

感謝stillfish00
大部分的問題都解決了
而且學到精簡的寫法,受益良多



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)