Excel使用VB遍历获取文件夹名称/位置/大小，管理硬盘好帮手。

独行剑侠

简单说明过程：
手上超过200多块移动硬盘，想要快速统计每一块硬盘里的内容，而且还想快速的放在Excel表格里。
具体为啥要统计这个？……反正领导需要。
反正看同事在一次次的Ctrl CV就头疼，你们就这么工作的？？？


太会了……
太会摸鱼了，像我这么喜欢效率的人，怎么能忍受这个？？？

好了，先叙述要求
Excel表格第一行要求是硬盘名称。
从第二行开始【文件夹名称】【硬盘名称+文件夹名称】【文件（夹）大小】
另外【硬盘名称+文件夹名称】要求鼠标点击即可进入硬盘文件夹。
因为不需要遍历子文件夹，只需要统计硬盘打开后第一层文件夹以及文件即可。

实现方式。Excel+VB

先去 文件→选项→自定义功能区→勾选√开发工具 确认
在Excel顶部菜单栏点击  开发工具→Visual Basic
输入以下脚本内容

[JavaScript] 纯文本查看 复制代码

Sub GetFirstLevelFolderAndFileDetails()
    Dim fso As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim file As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim drivePath As String
    Dim driveName As String
    
    ' 弹出文件夹选择对话框
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选哪个硬盘进行筛选？"
        If .Show = -1 Then
            drivePath = .SelectedItems(1)
        Else
            MsgBox "未选择硬盘盘符，后边我咋搜索？！"
            Exit Sub
        End If
    End With
    
    ' 创建文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 获取指定硬盘盘符
    Set folder = fso.GetFolder(drivePath)
    
    ' 获取硬盘名称
    driveName = fso.GetDrive(fso.GetDriveName(drivePath)).VolumeName
    
    ' 设置工作表
    Set ws = ThisWorkbook.Sheets(1)
    ws.Cells.Clear
    
    ' 合并第一行四个单元格并标注硬盘名称
    ws.Range("A1:D1").Merge
    ws.Cells(1, 1).Value = "硬盘名称: " & driveName
    ws.Cells(1, 1).Font.Bold = True
    ws.Cells(1, 1).HorizontalAlignment = xlCenter
    
    ' 写入表头
    ws.Cells(2, 1).Value = "名称"
    ws.Cells(2, 2).Value = "路径"
    ws.Cells(2, 3).Value = "类型"
    ws.Cells(2, 4).Value = "大小"
    
    ' 初始化行号
    lastRow = 3
    
    ' 遍历第一层子文件夹
    On Error Resume Next ' 开始错误处理
    For Each subFolder In folder.SubFolders
        If Err.Number = 0 Then
            ' 跳过特定文件夹
            If subFolder.Name <> "System Volume Information" And subFolder.Name <> "$RECYCLE.BIN" Then
                ws.Cells(lastRow, 1).Value = subFolder.Name
                ws.Hyperlinks.Add Anchor:=ws.Cells(lastRow, 2), Address:=subFolder.Path, TextToDisplay:=driveName & "\" & subFolder.Name
                ws.Cells(lastRow, 3).Value = "文件夹"
                
                ' 计算文件夹大小
                ws.Cells(lastRow, 4).Value = FormatFileSize(GetFolderSize(subFolder))
                
                lastRow = lastRow + 1
            End If
        Else
            ' 处理权限被拒绝的情况
            Err.Clear
        End If
    Next subFolder
    On Error GoTo 0 ' 结束错误处理
    
    ' 遍历第一层文件
    On Error Resume Next ' 开始错误处理
    For Each file In folder.Files
        If Err.Number = 0 Then
            ws.Cells(lastRow, 1).Value = file.Name
            ws.Hyperlinks.Add Anchor:=ws.Cells(lastRow, 2), Address:=file.Path, TextToDisplay:=driveName & "\" & file.Name
            ws.Cells(lastRow, 3).Value = "文件"
            ws.Cells(lastRow, 4).Value = FormatFileSize(file.size)
            
            lastRow = lastRow + 1
        Else
            ' 处理权限被拒绝的情况
            Err.Clear
        End If
    Next file
    On Error GoTo 0 ' 结束错误处理
    
    ' 调整列宽
    ws.Columns("A:D").AutoFit
    
    MsgBox "文件夹和文件信息已提取完成！"
End Sub

Function GetFolderSize(ByVal folder As Object) As Double
    Dim file As Object
    Dim subFolder As Object
    Dim folderSize As Double
    
    ' 初始化文件夹大小
    folderSize = 0
    
    ' 遍历文件夹中的文件
    On Error Resume Next ' 开始错误处理
    For Each file In folder.Files
        If Err.Number = 0 Then
            folderSize = folderSize + file.size
        Else
            ' 处理权限被拒绝的情况
            Err.Clear
        End If
    Next file
    
    ' 遍历子文件夹
    For Each subFolder In folder.SubFolders
        If Err.Number = 0 Then
            folderSize = folderSize + GetFolderSize(subFolder)
        Else
            ' 处理权限被拒绝的情况
            Err.Clear
        End If
    Next subFolder
    On Error GoTo 0 ' 结束错误处理
    
    GetFolderSize = folderSize
End Function

Function FormatFileSize(size As Double) As String
    If size >= 1073741824 Then
        FormatFileSize = Format(size / 1073741824, "0.00") & " GB"
    ElseIf size >= 1048576 Then
        FormatFileSize = Format(size / 1048576, "0.00") & " MB"
    Else
        FormatFileSize = Format(size, "0.00") & " B"
    End If
End Function

自动获取硬盘信息（文件夹-路径-大小）.zip (23.11 KB, 下载次数: 208)

2024-11-6 18:40 上传

点击文件名下载附件

现成的直接下载，解压即用，记得选择启用宏


保存，格式XLSM


叉×掉Visual Basic页面，在在Excel顶部菜单栏点击  插入形状。
在表格内画个长方形当按钮，右键→指定宏→选择刚刚设定好的宏（初次设置应该只有一个）→点击确认。


此时，点击按钮，就会跳出选择硬盘盘符的提示

截图1

选择硬盘→点击确定
等待……
就会在表格内出现以下内容





好了，你们看看，200多块硬盘，一上午就解决了。
他们说这个任务至少三个人加班加点儿，也得一星期才能做完？
我只需要一上午！
领导不得夸夸我升职加薪？
不说了，我要去汇报了。
我！！！做好加薪准备啦！

houdongen

领导:好，其他人下班吧，手上剩下的工作交接给你....

lzspain

升职加薪？不可能的，以后都得你来干

changhong8

这一类的效率工具，必须附带正确的使用方法说明书。搞好了皆大欢喜，搞不好自讨苦吃。

lixiangliuyi

大兄弟，抛开技术不说，你这样很容易被开掉的 ，你这让部门没法领经费和报销了啊 ，这，要有点眼力见，你可以找几个同事过来一起先摸鱼4,5天然后再VBA里面写个延时处理，总之在最后的时刻，完成就行了，

方案我感觉用python做，也很可行，
1，写个遍历循环锁定外接硬盘，
2，写个方法，定位os.chdir()
3，遍历根目录，os.listdir()
4，导入excel模块。写入

思路就是这个但是水平有限，写不出成品。抱歉

tydzjing

楼主太年轻了，你这么快把活干完，其他同事如何领加班费？其他同事如何以加班为理由加夜宵？如何小群体团建？

canghaisui

谢谢分享，试了一下非常赞！不过请老大完善优化一下，比如我想遍历提取一块硬盘中的某个文件夹中的文件夹下面的文件夹及文件名称，其路径显示有问题？谢谢

a147888123

everything就行了

Ty007

效率是减少烦恼的不是吗~

winos8

准备裁员                                    

ruanxiaoqi

感谢分享

lwz373146809

行，有点意思，感谢分享

dxxiong

领导窃喜，一个顶三，可以裁员了