- 帖子
- 1527
- 主題
- 40
- 精華
- 0
- 積分
- 1551
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-11-4
|
5#
發表於 2023-1-4 11:55
| 只看該作者
回復 3# millerch
如果是要資料夾檔案明細! 這是 准提部林前輩的方法
執行前:
執行結果:
Sub 清除()
Dim y&, z&
With ActiveSheet
If .AutoFilterMode Then .AutoFilterMode = False
y = .UsedRange.Rows.Count
z = .[Uhead].Row + 1
If y > z Then .Rows(z + 1 & ":" & y).EntireRow.Delete
.Rows(z).ClearContents
.[Uhead].Cells(2).Resize(1, 2) = Array("■", "本列請勿刪除")
End With
ActiveWindow.ScrollRow = 1
End Sub
Sub 載入檔案()
Dim MyPath, uPath, xD1, xD2, Urr, UU, OBJ, GFD, UFD, GFL, UFL, GG
Dim j&, Jm&, k&, Km&, x, Xm, ExName$, XX$, Arr, VV$, CCunt&, UCunt&
Call 清除: MyPath = ThisWorkbook.FullName
uPath = [B1]
If uPath = "" Then MsgBox "路徑未輸入!": Exit Sub
If [B1] = "MyPath" Then uPath = ThisWorkbook.Path
If Dir(uPath, vbDirectory) = "" Then MsgBox "找不到路徑!": Exit Sub
If [B2] = "" Then MsgBox "副檔名未輸入!": Exit Sub
ExName = "," & UCase([B2]) & ",": If [B2] = "*.*" Then ExName = "1"
'----------------------------------------
[E4] = "∼∼正在擷取檔案明細，執行中可按ESC中止∼∼"
Application.EnableCancelKey = xlErrorHandler
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set xD1 = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Urr = Array(uPath)
RE_GET:
On Error GoTo 999
For Each UU In Urr
If Len(UU) < 3 Then
Set GFD = OBJ.GetDrive(UU)
VV = UCase(UU)
Set UFD = GFD.RootFolder.SubFolders
Set GFL = GFD.RootFolder.Files
Else
Set GFD = OBJ.GetFolder(UU)
VV = GFD.Name: SZ = 0
Set UFD = GFD.SubFolders
Set GFL = GFD.Files
End If
'-------------------------------
k = 0: Xm = 0: UCunt = 0
On Error Resume Next
UCunt = GFL.Count '遇到〔System Volume Information〕會錯誤
On Error GoTo 999
If UCunt = 0 Then GoTo GET_SubFolder
For Each GG In GFL
If GG.Path = MyPath Then GoTo 101
XX = UCase(OBJ.GetExtensionName(GG.Path))
If XX = "" Then XX = "未知"
If ExName = "1" Then j = 1 Else j = InStr(ExName, "," & XX & ",")
If j = 0 Then GoTo 101
Jm = Jm + 1: k = 1
x = GG.Size / 1024: Xm = Xm + x
xD1(Jm) = Array(GG.Name, XX, x, UU & "\")
Application.StatusBar = "■■■正在擷取檔案名稱：(" & Jm & ")" & GG.Name
101: Next
If k = 1 Then Jm = Jm + 1: xD1(Jm) = Array("＼" & VV & "＼", "", Xm, UU)
'----------------------------------------------
GET_SubFolder:
UCunt = 0
On Error Resume Next
UCunt = UFD.Count '遇到〔System Volume Information〕會錯誤
On Error GoTo 999
If UCunt > 0 Then
For Each GG In UFD
Km = Km + 1: xD2(Km) = GG.Path
Next
End If
Next
CCunt = CCunt + 1
If Val([C4]) > 0 Then If CCunt >= [C4] Then Km = 0
If Km > 0 Then Urr = xD2.items: xD2.RemoveAll: Km = 0: GoTo RE_GET
'---------------------------------------
If Jm = 0 Then MsgBox "找不到符合檔案！": GoTo 999
If Jm > Rows.Count - 1 Then MsgBox "檔案明細超過工作表可容納列數！": GoTo 999
Application.StatusBar = "■■■載入及整理資料中．．．．．"
ReDim Arr(Jm - 1, 3): k = 0
For Each UU In xD1.items
Arr(k, 0) = UU(0): Arr(k, 1) = UU(1)
Arr(k, 2) = UU(2): Arr(k, 3) = UU(3): k = k + 1
Next
With [Uhead].Cells(2, 1).Resize(Jm, 5)
.Rows(1).Copy .Cells
.Item(2).Resize(Jm, 4) = Arr
.Sort Key1:=.Item(2), Order1:=xlAscending, Header:=xlNo
.Sort Key1:=.Item(5), Order1:=xlAscending, Header:=xlNo
.Columns(1).FormulaR1C1 = "=IF(RC[2]="""",HYPERLINK(RC[4],""■""),N(R[-1]C)+1)"
End With
[D1] = "=SUMIF(A7:A" & Jm + 6 & ","">0"",D7:D" & Jm + 6 & ")"
999: [E4] = "": Application.StatusBar = False
End Sub
Sub 載入資料夾()
Dim uPath, xD1, xD2, Urr, UU, OBJ, GFD, UFD, GG
Dim j&, Jm&, k&, Km&, Arr, VV$, SZ, CCunt&, UCunt&
Call 清除: uPath = [B1]
If uPath = "" Then MsgBox "路徑未輸入!": Exit Sub
If [B1] = "MyPath" Then uPath = ThisWorkbook.Path
If Right(uPath, 1) = "\" Then uPath = Left(uPath, Len(uPath) - 1)
If Dir(uPath, vbDirectory) = "" Then MsgBox "路徑錯誤！": Exit Sub
'----------------------------------------
[E4] = "∼∼正在擷取資料夾，執行中可按ESC停止∼∼"
Application.EnableCancelKey = xlErrorHandler
Set OBJ = CreateObject("Scripting.FileSystemObject")
Set xD1 = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Urr = Array(uPath)
RE_GET:
On Error GoTo 999
For Each UU In Urr
If Len(UU) < 3 Then
Set GFD = OBJ.GetDrive(UU)
VV = UCase(UU)
SZ = GFD.TotalSize - GFD.FreeSpace
Set UFD = GFD.RootFolder.SubFolders
Else
Set GFD = OBJ.GetFolder(UU)
VV = GFD.Name: SZ = 0
On Error Resume Next
SZ = GFD.Size '遇到〔System Volume Information〕會錯誤
On Error GoTo 999
Set UFD = GFD.SubFolders
End If
Jm = Jm + 1: xD1(Jm) = Array("＼" & VV & "＼", "Folder", SZ / 1024, UU)
Application.StatusBar = "■■■正在擷取資料夾名稱：(" & Jm & ")" & VV
UCunt = 0
On Error Resume Next
UCunt = UFD.Count '遇到〔System Volume Information〕會錯誤
On Error GoTo 999
If UCunt = 0 Then GoTo 101
For Each GG In UFD
Km = Km + 1: xD2(Km) = GG.Path
Next
101: Next
CCunt = CCunt + 1
If Val([C4]) > 0 Then If CCunt >= [C4] Then Km = 0
If Km > 0 Then Urr = xD2.items: xD2.RemoveAll: Km = 0: GoTo RE_GET
'---------------------------------------
If Jm > Rows.Count - 1 Then MsgBox "資料夾數量超過工作表可容納列數！": GoTo 999
Application.StatusBar = "■■■載入及整理資料中．．．．．"
ReDim Arr(Jm - 1, 3)
For Each UU In xD1.items
Arr(k, 0) = UU(0): Arr(k, 1) = UU(1)
Arr(k, 2) = UU(2): Arr(k, 3) = UU(3): k = k + 1
Next
With [Uhead].Cells(2, 1).Resize(Jm, 5)
.Rows(1).Copy .Cells
.Item(2).Resize(Jm, 4) = Arr
.Sort Key1:=.Item(5), Order1:=xlAscending, Header:=xlNo
.Columns(1).FormulaR1C1 = "=IF(RC[3]="""","""",HYPERLINK(RC[4],""■""))"
End With
[D1] = "=D7"
999: [E4] = "": Application.StatusBar = False
End Sub |
|
發表於 2023-1-9 21:14
| 
