返回列表 上一主題 發帖

[發問] 請教如何列出所有的子資料夾名

[發問] 請教如何列出所有的子資料夾名

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

求助是否可達成此功能?
感謝幫忙:loveliness:

test1.rar (75.29 KB)

檔案&資料夾

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

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

  11. Sub FilesHierarchy(fd, hierarchy As String)
  12.     Dim i As Long
  13.     With fd
  14.         Cells(Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(1, 4) = Array(hierarchy, .Name, .ParentFolder.Path, "資料夾")
  15.         For Each x In .SubFolders
  16.             i = i + 1
  17.             FilesHierarchy x, hierarchy & "." & i   'recursive call
  18.         Next
  19.         For Each x In .Files
  20.             i = i + 1
  21.             Cells(Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(1, 4) = Array(hierarchy & "." & i, x.Name, .Path, "檔案")
  22.         Next
  23.     End With
  24. End Sub
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

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

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

謝謝

test1-1.rar (35.99 KB)

TOP

回復 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
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

回復 4# stillfish00
感謝stillfish00

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

想不出有效的方法去除
再討教(如附件),感謝

test1.rar (33.09 KB)

TOP

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

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

  13. Dim cOffset As Long, ar
  14. For r = 4 To [a65536].End(3).Row     '作樹狀圖
  15.     ar = Split(Cells(r, 1), ".")
  16.     cOffset = UBound(ar)  '階層數
  17.     With Cells(r, 8 + cOffset)
  18.         .Value = Cells(r, 3)
  19.         .Interior.ColorIndex = IIf(Cells(r, 2) = "資料夾", 36, xlNone)
  20.         .Borders(xlEdgeBottom).LineStyle = xlContinuous
  21.         .Borders(xlEdgeBottom).Weight = xlThick
  22.         .Borders(xlEdgeLeft).LineStyle = xlContinuous
  23.     End With
  24.    
  25.     If ar(cOffset) <> "x" And ar(cOffset) <> "1" Then
  26.         For i = r - 1 To 4 Step -1
  27.             If Cells(i, 8 + cOffset) <> "" Then Exit For
  28.             Cells(i, 8 + cOffset).Borders(xlEdgeLeft).LineStyle = xlContinuous
  29.         Next
  30.     End If
  31.    
  32. Next
  33. Application.ScreenUpdating = True
  34. End Sub
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

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

TOP

        靜思自在 : 做好事不能少我一人,做壞事不能多我一人。
返回列表 上一主題