麻辣家族討論版版 » Excel程式區 » 請教如何列出所有的子資料夾名

返回列表下一主題上一主題發帖

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

中學生 Rank: 2

帖子: 32
主題: 9
精華: 0
積分: 122
點名: 0
作業系統: WINXP
軟體版本: Office XP
閱讀權限: 20
性別: 男
註冊時間: 2010-5-14
最後登錄: 2024-3-20

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2015-12-17 12:19 | 只看該作者

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

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

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

test1.rar (75.29 KB)

檔案&資料夾

樓主熱帖

收藏

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

2^#

發表於 2015-12-17 14:27 | 只看該作者

回復 1# 巴克斯

Sub 列出明細2()
[B1] = ActiveWorkbook.Path
Range([a4], [f65536]).ClearContents
Range([a4], [f65536]).Interior.ColorIndex = xlNone
Dim fs, fd
Set fs = CreateObject("Scripting.FileSystemObject")
Set fd = fs.GetFolder([B1].Value)
FilesHierarchy fd, "x"
End Sub
Sub FilesHierarchy(fd, hierarchy As String)
Dim i As Long
With fd
Cells(Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(1, 4) = Array(hierarchy, .Name, .ParentFolder.Path, "資料夾")
For Each x In .SubFolders
i = i + 1
FilesHierarchy x, hierarchy & "." & i 'recursive call
Next
For Each x In .Files
i = i + 1
Cells(Rows.Count, 1).End(xlUp).Cells(2, 1).Resize(1, 4) = Array(hierarchy & "." & i, x.Name, .Path, "檔案")
Next
End With
End Sub

複製代碼

表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

中學生 Rank: 2

帖子: 32
主題: 9
精華: 0
積分: 122
點名: 0
作業系統: WINXP
軟體版本: Office XP
閱讀權限: 20
性別: 男
註冊時間: 2010-5-14
最後登錄: 2024-3-20

3^#

發表於 2015-12-17 17:11 | 只看該作者

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

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

謝謝

test1-1.rar (35.99 KB)

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

4^#

發表於 2015-12-17 19:35 | 只看該作者

回復 3# 巴克斯

Dim cOffset As Long
For r = 4 To [a65536].End(3).Row
cOffset = UBound(Split(Cells(r, 1), "."))
With Cells(r, 8 + cOffset)
.Value = Cells(r, 3)
.Interior.ColorIndex = IIf(Cells(r, 2) = "資料夾", 36, xlNone)
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
For c = 9 To 8 + cOffset - 1
Cells(r, c).Borders(xlEdgeLeft).LineStyle = xlContinuous
Next
Next
Application.ScreenUpdating = True

複製代碼

表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

中學生 Rank: 2

帖子: 32
主題: 9
精華: 0
積分: 122
點名: 0
作業系統: WINXP
軟體版本: Office XP
閱讀權限: 20
性別: 男
註冊時間: 2010-5-14
最後登錄: 2024-3-20

5^#

發表於 2015-12-18 09:09 | 只看該作者

回復 4# stillfish00
感謝stillfish00

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

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

test1.rar (33.09 KB)

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

6^#

發表於 2015-12-18 11:10 | 只看該作者

回復 5# 巴克斯

Sub 列出明細()
[b1] = ActiveWorkbook.Path
Range([a4], [f65536]).ClearContents
[a4:a65536].EntireRow.Delete
Application.ScreenUpdating = False
Dim fs, fd
Set fs = CreateObject("Scripting.FileSystemObject")
Set fd = fs.GetFolder([b1].Value) '根目錄
FilesHierarchy fd, "x"
Range([a4], Cells([a65536].End(3).Row, 6)).Borders.LineStyle = 1
Range([a4], [a65536].End(3)).RowHeight = 24
Dim cOffset As Long, ar
For r = 4 To [a65536].End(3).Row '作樹狀圖
ar = Split(Cells(r, 1), ".")
cOffset = UBound(ar) '階層數
With Cells(r, 8 + cOffset)
.Value = Cells(r, 3)
.Interior.ColorIndex = IIf(Cells(r, 2) = "資料夾", 36, xlNone)
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeLeft).LineStyle = xlContinuous
End With
If ar(cOffset) <> "x" And ar(cOffset) <> "1" Then
For i = r - 1 To 4 Step -1
If Cells(i, 8 + cOffset) <> "" Then Exit For
Cells(i, 8 + cOffset).Borders(xlEdgeLeft).LineStyle = xlContinuous
Next
End If
Next
Application.ScreenUpdating = True
End Sub

複製代碼

表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

中學生 Rank: 2

帖子: 32
主題: 9
精華: 0
積分: 122
點名: 0
作業系統: WINXP
軟體版本: Office XP
閱讀權限: 20
性別: 男
註冊時間: 2010-5-14
最後登錄: 2024-3-20

7^#

發表於 2015-12-18 17:05 | 只看該作者

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

靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。

返回列表下一主題上一主題