[已解决]求一段VBA读取一个文件夹里面的所有文件的文件名和大小的代码

皮皮2

求一段VBA读取一个文件夹里面的所有文件的文件名和大小的代码，要求读取一个文件夹里面的所有文件名和文件夹名，并读取它们的大小，放在VBA读取一个文件夹里面的所有文件的文件名和大小.xlsx里





示例.rar (97.04 KB, 下载次数: 75)

2015-6-12 09:40 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hysys32

2015-6-12 10:25

Sub getfile()
    On Error Resume Next
    [a:b] = ""
    Dim mpath$ '打开路径位置
    ' Dim fso As FileSystemObject
    ' Dim mfolder As Folder
    ' Dim mfile As File '循环遍历文件
    Dim rarr() As Variant '结果数组
    Dim k&
    With Application.FileDialog(msoFileDialogFolderPicker) '文件夹对话框
        .Show
        mpath = .SelectedItems(1)
    End With
    Set fso = CreateObject("scripting.filesystemobject") 'fso
    ReDim rarr(1 To fso.GetFolder(mpath).Files.Count + fso.GetFolder(mpath).SubFolders.Count, 1 To 2)
    For Each mfile In fso.GetFolder(mpath).Files
        k = k + 1
        rarr(k, 1) = mfile.Name
        rarr(k, 2) = Round(mfile.Size / 1024 / 1024, 4) & "MB"
    Next
    For Each mfolder In fso.GetFolder(mpath).SubFolders
        k = k + 1
        rarr(k, 1) = mfolder.Name
        rarr(k, 2) = Round(mfolder.Size / 1024 / 1024, 4) & "MB"
    Next
    [A1].Resize(k, 2) = rarr
End Sub

简单写了下、、、、

跳转到最佳答案楼层

hysys32

Sub getfile()
    On Error Resume Next
    [a:b] = ""
    Dim mpath$ '打开路径位置
    ' Dim fso As FileSystemObject
    ' Dim mfolder As Folder
    ' Dim mfile As File '循环遍历文件
    Dim rarr() As Variant '结果数组
    Dim k&
    With Application.FileDialog(msoFileDialogFolderPicker) '文件夹对话框
        .Show
        mpath = .SelectedItems(1)
    End With
    Set fso = CreateObject("scripting.filesystemobject") 'fso
    ReDim rarr(1 To fso.GetFolder(mpath).Files.Count + fso.GetFolder(mpath).SubFolders.Count, 1 To 2)
    For Each mfile In fso.GetFolder(mpath).Files
        k = k + 1
        rarr(k, 1) = mfile.Name
        rarr(k, 2) = Round(mfile.Size / 1024 / 1024, 4) & "MB"
    Next
    For Each mfolder In fso.GetFolder(mpath).SubFolders
        k = k + 1
        rarr(k, 1) = mfolder.Name
        rarr(k, 2) = Round(mfolder.Size / 1024 / 1024, 4) & "MB"
    Next
    [A1].Resize(k, 2) = rarr
End Sub

简单写了下、、、、

qh8600

1. Sub demo()
   
2.     Dim fs, ar(1 To 100, 1 To 2), n
   
3.     Application.ScreenUpdating = False
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     Set fs = fso.GetFolder(ThisWorkbook.Path)
   
6.     For Each fd In fs.subfolders
   
7.         n = n + 1
   
8.         ar(n, 1) = fd.Name
   
9.         ar(n, 2) = Int(fd.Size / 102.4) / 10
   
10.     Next
    
11.     For Each fd In fs.Files
    
12.         If Not (fd.Name Like "*" & ThisWorkbook.Name) Then
    
13.             n = n + 1
    
14.             ar(n, 1) = Split(fd.Name, ".")(0)
    
15.             ar(n, 2) = Int(fd.Size / 102.4) / 10
    
16.         End If
    
17.     Next
    
18.     Range("a2").Resize(65535, 2).ClearContents
    
19.     Range("a2").Resize(n, 2) = ar
    
20.     Application.ScreenUpdating = True
    
21. End Sub

复制代码

我也写一个试试，不过直接获取KB不会

E-H-P

1.     Dim arr(1 To 65536, 1 To 2), RngAddress As String
   
2.     Dim MyFile, win As String, i&
   
3.     Dim rng As Range, Rg As Range
   
4.     Dim fd As FileDialog
   
5.     Dim fso As Object
   
6.     Dim fld
   
7.     Set fso = CreateObject("scripting.filesystemobject")
   
8.    
   
9.     RngAddress = Selection.Address
   
10.     Set fd = Application.FileDialog(msoFileDialogFolderPicker) '弹出打开对话框，选择文件夹
    
11.     If fd.Show = -1 Then
    
12.         Set rng = Application.InputBox("请选择区域：（默认为活动单位格）", , RngAddress, Type:=8) '选择放置链接区域
    
13.         If rng Is Nothing Then Exit Sub
    
14.         win = fd.InitialFileName
    
15.         
    
16.         MyFile = Dir(win, vbDirectory)
    
17.         Do While MyFile <> ""
    
18.                 i = i + 1
    
19.                 If (GetAttr(MyFile) And vbDirectory) = vbDirectory Then
    
20.                     If MyFile <> "." Then
    
21.                     If MyFile <> ".." Then
    
22.                     Set fld = fso.GetFolder(win & MyFile)
    
23.                     arr(i, 1) = MyFile
    
24.                     arr(i, 2) = fld.Size / 1024
    
25.                     Set fld = Nothing
    
26.                     End If
    
27.                     End If
    
28.                 Else
    
29.                 arr(i, 1) = MyFile
    
30.                 arr(i, 2) = FileLen(MyFile) / 1024
    
31.                 End If
    
32.                 MyFile = Dir
    
33.         Loop
    
34.         
    
35.         With [a2].Resize(i, 2)
    
36.             .ClearContents
    
37.             .Value = arr
    
38.         End With
    
39.     End If
    
40. 
    
41. End Sub

复制代码