[已解决]【求教】提取文件夹大小

xdwy81129

入题，因为电脑上一次全部查看出文件夹的大下
希望能用vba实现：在A列名列“D:\文件\”下的所有文件夹的名称，第三级如果还有文件夹，就不需要列出来了
然后在同行的B列名列“D:\文件\”下的所有文件夹的大小，以MB计量
如果可以，请在A列创建连接到各文件夹

谢谢指教。

最佳答案

月排行榜 / 总排行榜

爱疯

2010-10-29 20:43

Sub b()
    Dim fs As Object, fd As Object
    Dim p As String, fld As String
    Dim s As Integer

    Columns("A:B").Clear
    Set fs = CreateObject("Scripting.FileSystemObject")
    p = "f:\1\"    '手动指定路径

    On Error Resume Next
    fld = Dir(p, vbDirectory)
    Do While fld <> ""
        Set fd = fs.GetFolder(p & fld)
        If InStr(fld, ".") = False Then
            s = s + 1
            Cells(s, 1) = fld
            Cells(s, 2) = Format(fd.Size / 1024 / 1024, "0.000")

            ActiveSheet.Hyperlinks.Add Anchor:=Cells(s, 1), _
                                       Address:=p & fld, _
                                       TextToDisplay:=fld
        End If
        fld = Dir
    Loop
End Sub

不过，不显示隐藏文件夹

[em04]

跳转到最佳答案楼层

那么的帅

文件夹大小 什么概念？

xdwy81129

QUOTE:

以下是引用那么的帅在2010-10-29 16:36:00的发言：
文件夹大小 什么概念？

就是多大，多少mb呀

 

【求教】提取文件夹大小

如这个图，159mb，或者163mb都好

爱疯

Sub a()
    Dim Mypath As String, Myfile As String
    Dim fs As Object, f As Object
    Dim s As Integer
    Dim arr() As String


    Set fs = CreateObject("Scripting.FileSystemObject")
    Mypath = "d:\" '指定或修改的路径
    
    Myfile = Dir(Mypath & "\*.*")
    Do While Myfile <> ""
        Set f = fs.GetFile(Mypath & Myfile)
        s = s + 1
        ReDim Preserve arr(1 To 2, 1 To s)
        arr(1, s) = f.Name
        arr(2, s) = Format(f.Size / 1024 / 1024, "0.000")
        Myfile = Dir
    Loop
    
    Columns("A:B").Clear
    [A1].Resize(s, 2) = Application.Transpose(arr)
    
End Sub

不过，不能显示隐藏文件。

xdwy81129

QUOTE:

以下是引用爱疯在2010-10-29 17:05:00的发言：

Sub a()
    Dim Mypath As
   String, Myfile As
   String
    Dim fs As
   Object, f As
   Object
    Dim s As
   Integer
    Dim arr() As
   String


    Set fs = CreateObject("Scripting.FileSystemObject")
    Mypath = "d:\" '指定或修改的路径
    
    Myfile = Dir(Mypath & "\*.*")
    Do
   While Myfile <> ""
        Set f = fs.GetFile(Mypath & Myfile)
        s = s + 1
        ReDim
   Preserve arr(1 To 2, 1 To s)
        arr(1, s) = f.Name
        arr(2, s) = Format(f.Size / 1024 / 1024, "0.000")
        Myfile = Dir
    Loop
    
    Columns("A:B").Clear
    [A1].Resize(s, 2) = Application.Transpose(arr)
    
End
   Sub

不过，不能显示隐藏文件。

不好意思，这个不对

我请教的是，提取文件夹的大小，不是文件的大小

另外，A列文件夹的名称还需要超链接到该文件夹

xdwy81129

自己再顶顶，希望高手能解决

爱疯

Sub b()
    Dim fs As Object, fd As Object
    Dim p As String, fld As String
    Dim s As Integer

    Columns("A:B").Clear
    Set fs = CreateObject("Scripting.FileSystemObject")
    p = "f:\1\"    '手动指定路径

    On Error Resume Next
    fld = Dir(p, vbDirectory)
    Do While fld <> ""
        Set fd = fs.GetFolder(p & fld)
        If InStr(fld, ".") = False Then
            s = s + 1
            Cells(s, 1) = fld
            Cells(s, 2) = Format(fd.Size / 1024 / 1024, "0.000")

            ActiveSheet.Hyperlinks.Add Anchor:=Cells(s, 1), _
                                       Address:=p & fld, _
                                       TextToDisplay:=fld
        End If
        fld = Dir
    Loop
End Sub

不过，不显示隐藏文件夹

[em04]

xdwy81129

QUOTE:

以下是引用爱疯在2010-10-29 20:43:00的发言：

Sub b()
    Dim fs As
   Object, fd As
   Object
    Dim p As
   String, fld As
   String
    Dim s As
   Integer

    Columns("A:B").Clear
    Set fs = CreateObject("Scripting.FileSystemObject")
    p = "f:\1\"    '手动指定路径

    On
   Error
   Resume
   Next
    fld = Dir(p, vbDirectory)
    Do
   While fld <> ""
        Set fd = fs.GetFolder(p & fld)
        If InStr(fld, ".") = False
   Then
            s = s + 1
            Cells(s, 1) = fld
            Cells(s, 2) = Format(fd.Size / 1024 / 1024, "0.000")

            ActiveSheet.Hyperlinks.Add Anchor:=Cells(s, 1), _
                                       Address:=p & fld, _
                                       TextToDisplay:=fld
        End
   If
        fld = Dir
    Loop
End
   Sub

不过，不显示隐藏文件夹

[em04]

谢谢2个答案了

为什么2个答案都回避隐藏的文件、文件夹呢？？

爱疯

Sub a()
    Dim Mypath As String, Myfile As String
    Dim fs As Object, f As Object
    Dim s As Integer
    Dim arr() As String


    Set fs = CreateObject("Scripting.FileSystemObject")
    Mypath = "d:\" '指定或修改的路径
    
    Myfile = Dir(Mypath & "\*.*", 2)
    Do While Myfile <> ""
        Set f = fs.GetFile(Mypath & Myfile)
        s = s + 1
        ReDim Preserve arr(1 To 2, 1 To s)
        arr(1, s) = f.Name
        arr(2, s) = Format(f.Size / 1024 / 1024, "0.000")
        Myfile = Dir
    Loop
    
    If s = 0 Then End
    Columns("A:B").Clear
    [A1].Resize(s, 2) = Application.Transpose(arr)
    
End Sub

修改了下a。

是否显示隐藏，可选择dir()的第2个参数值。

显示隐藏文件夹的话：fld = Dir(p, 18)

xdwy81129

QUOTE:

以下是引用爱疯在2010-10-29 21:09:00的发言：

Sub a()
    Dim Mypath As
   String, Myfile As
   String
    Dim fs As
   Object, f As
   Object
    Dim s As
   Integer
    Dim arr() As
   String


    Set fs = CreateObject("Scripting.FileSystemObject")
    Mypath = "d:\" '指定或修改的路径
    
    Myfile = Dir(Mypath & "\*.*", 2)
    Do
   While Myfile <> ""
        Set f = fs.GetFile(Mypath & Myfile)
        s = s + 1
        ReDim
   Preserve arr(1 To 2, 1 To s)
        arr(1, s) = f.Name
        arr(2, s) = Format(f.Size / 1024 / 1024, "0.000")
        Myfile = Dir
    Loop
    
    If s = 0 Then
   End
    Columns("A:B").Clear
    [A1].Resize(s, 2) = Application.Transpose(arr)
    
End
   Sub

修改了下a。

是否显示隐藏，可选择dir()的第2个参数值。

显示隐藏文件夹的话：fld = Dir(p, 18)

谢谢，谢谢，很谢谢。