[已解决]能否用VBA实现，提取模板所在路径的一级文件夹的容量？谢谢文刀天可老师！

lhj323323

老师：

本需求没有上传模板

我想达到的效果是：
1、一级文件夹的定义是，在磁盘根目录显示的文件夹。
这个文件夹内有多少文件夹，不必读取。
2、根目录内存在的【非文件夹】类型的其它格式的文档，不纳入统计范围。
3、通过EXCEL的VBA功能提取数据后，导入到模板的sheet2工作表中，格式如下：
     磁盘，文件夹名，容量
就这三列。

先谢谢了。

最佳答案

月排行榜 / 总排行榜

文刀天可

2016-6-9 12:31

新建一个excel文件试下吧

1. Dim cnt%
   
2. Sub test()
   
3.     Dim fso As Object, dri As Object
   
4.     Dim i As Integer
   
5.     Dim str$, t
   
6.     Range("a1").CurrentRegion.Clear
   
7.     t = Timer
   
8.     i = 1
   
9.     cnt = 0
   
10.     Set fso = CreateObject("Scripting.FileSystemObject")
    
11.     With ThisWorkbook.Worksheets("sheet1")
    
12.     .Cells(i, 1).Resize(1, 3) = Array("盘符", "已用空间", "容量")
    
13.     For Each dri In fso.Drives
    
14.         If dri.IsReady Then
    
15.             i = i + 1
    
16.             .Cells(i, 1) = dri.driveletter    '盘符
    
17.             .Cells(i, 2) = Format((dri.TotalSize - dri.AvailableSpace) / 1024 ^ 3, "0.0G")    '已用空间
    
18.             .Cells(i, 3) = Format(dri.TotalSize / 1024 ^ 3, "0G")    '容量
    
19.         End If
    
20.         str = dri.Path & ""
    
21.         fldsize (str)
    
22.     Next
    
23.     End With
    
24.     MsgBox ("运行时间：" & Timer - t)
    
25. End Sub
    
26. Sub fldsize(str)
    
27. On Error Resume Next
    
28. Dim fso, fld, fld1
    
29. Set fso = CreateObject("scripting.filesystemobject")
    
30. Set fld = fso.getfolder(str)
    
31. With ThisWorkbook.Worksheets("sheet2")
    
32.    .Cells(1, 1).Resize(1, 4) = Array("盘符", "文件名", "文件路径", "文件夹大小")
    
33.     For Each fld1 In fld.subfolders
    
34.                .Range("A" & cnt + 2) = fld1.drive.driveletter
    
35.                .Range("B" & cnt + 2) = fld1.Name
    
36.                .Range("c" & cnt + 2) = fld1.Path
    
37.                .Range("D" & cnt + 2) = Format(fld1.Size / 1024 ^ 2, "0.00MB")
    
38.                 cnt = cnt + 1
    
39.     Next
    
40.   End With
    
41. End Sub
    

复制代码

跳转到最佳答案楼层

文刀天可

新建一个excel文件试下吧

1. Dim cnt%
   
2. Sub test()
   
3.     Dim fso As Object, dri As Object
   
4.     Dim i As Integer
   
5.     Dim str$, t
   
6.     Range("a1").CurrentRegion.Clear
   
7.     t = Timer
   
8.     i = 1
   
9.     cnt = 0
   
10.     Set fso = CreateObject("Scripting.FileSystemObject")
    
11.     With ThisWorkbook.Worksheets("sheet1")
    
12.     .Cells(i, 1).Resize(1, 3) = Array("盘符", "已用空间", "容量")
    
13.     For Each dri In fso.Drives
    
14.         If dri.IsReady Then
    
15.             i = i + 1
    
16.             .Cells(i, 1) = dri.driveletter    '盘符
    
17.             .Cells(i, 2) = Format((dri.TotalSize - dri.AvailableSpace) / 1024 ^ 3, "0.0G")    '已用空间
    
18.             .Cells(i, 3) = Format(dri.TotalSize / 1024 ^ 3, "0G")    '容量
    
19.         End If
    
20.         str = dri.Path & ""
    
21.         fldsize (str)
    
22.     Next
    
23.     End With
    
24.     MsgBox ("运行时间：" & Timer - t)
    
25. End Sub
    
26. Sub fldsize(str)
    
27. On Error Resume Next
    
28. Dim fso, fld, fld1
    
29. Set fso = CreateObject("scripting.filesystemobject")
    
30. Set fld = fso.getfolder(str)
    
31. With ThisWorkbook.Worksheets("sheet2")
    
32.    .Cells(1, 1).Resize(1, 4) = Array("盘符", "文件名", "文件路径", "文件夹大小")
    
33.     For Each fld1 In fld.subfolders
    
34.                .Range("A" & cnt + 2) = fld1.drive.driveletter
    
35.                .Range("B" & cnt + 2) = fld1.Name
    
36.                .Range("c" & cnt + 2) = fld1.Path
    
37.                .Range("D" & cnt + 2) = Format(fld1.Size / 1024 ^ 2, "0.00MB")
    
38.                 cnt = cnt + 1
    
39.     Next
    
40.   End With
    
41. End Sub
    

复制代码

文刀天可

截图

lhj323323

文刀天可 发表于 2016-6-9 12:31
新建一个excel文件试下吧

文老师：

谢谢您的答复，问题已解决

lhj323323

文刀天可 发表于 2016-6-9 12:35
截图

文老师：

你是否借用了爱疯老师的test语句？

两个语句组合运行了，耗时122秒，我换了台电脑再测试，也要用86秒，还有没有办法进一步提速？

lhj323323

文刀天可 发表于 2016-6-9 12:35
截图

还有个问题，生成的数据，各区之间存在空行，比如：

C盘到D盘的交界处，就有一空行。如何在语句中把这个空行去掉？