使用VBA统计多文件夹邮件数量以生成周报的实现方案

没问题！我帮你改造代码，让它能自动遍历目标根目录下的所有子文件夹（不管每周新增或删除多少），并统计每个文件夹里本周接收的邮件数量，还能把结果导出到Excel方便生成报告。

核心思路 #

1. 先指定要统计的根文件夹（比如收件箱，或者你自定义的文件夹组）
2. 递归遍历该根文件夹下的所有子文件夹（自动处理新增/删除的文件夹）
3. 对每个文件夹筛选出ReceivedTime在本周范围内的邮件
4. 统计数量并整理成结构化报告（这里用Excel输出，方便后续编辑）

完整VBA代码 #

Sub WeeklyFolderMailCount()
    Dim nmsName As Outlook.NameSpace
    Dim rootFolder As Outlook.Folder
    Dim excelApp As Object
    Dim excelWB As Object
    Dim rowNum As Integer
    
    ' 初始化Outlook命名空间
    Set nmsName = Application.GetNamespace("MAPI")
    
    ' --------------------------
    ' 这里修改为你的目标根文件夹
    ' 示例1：默认收件箱
    Set rootFolder = nmsName.GetDefaultFolder(olFolderInbox)
    ' 示例2：自定义根文件夹（比如邮箱下的"项目文件夹"）
    ' Set rootFolder = nmsName.Folders("你的邮箱地址@xxx.com").Folders("项目文件夹")
    ' --------------------------
    
    ' 初始化Excel应用
    Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = True ' 让Excel可见，方便查看结果
    Set excelWB = excelApp.Workbooks.Add
    
    ' 设置Excel表头
    rowNum = 1
    excelWB.Sheets(1).Cells(rowNum, 1) = "文件夹路径"
    excelWB.Sheets(1).Cells(rowNum, 2) = "本周邮件数量"
    rowNum = rowNum + 1
    
    ' 调用递归函数遍历所有文件夹
    Call TraverseFolders(rootFolder, excelWB, rowNum)
    
    ' 自动调整列宽
    excelWB.Sheets(1).Columns("A:B").AutoFit
    
    ' 释放对象
    Set excelWB = Nothing
    Set excelApp = Nothing
    Set rootFolder = Nothing
    Set nmsName = Nothing
    
    MsgBox "统计完成！结果已导出到Excel。", vbInformation
End Sub

' 递归遍历文件夹的函数
Sub TraverseFolders(currentFolder As Outlook.Folder, excelWB As Object, ByRef rowNum As Integer)
    Dim subFolder As Outlook.Folder
    Dim mailCount As Integer
    Dim startOfWeek As Date
    
    ' 计算本周的起始日期（周一0点）
    startOfWeek = Date - Weekday(Date, vbMonday) + 1
    startOfWeek = DateValue(startOfWeek) ' 去掉时间部分
    
    ' 筛选本周接收的邮件并统计数量
    mailCount = currentFolder.Items.Restrict("[ReceivedTime] >= '" & Format(startOfWeek, "ddddd hh:mm AMPM") & "'").Count
    
    ' 将结果写入Excel
    excelWB.Sheets(1).Cells(rowNum, 1) = currentFolder.FolderPath
    excelWB.Sheets(1).Cells(rowNum, 2) = mailCount
    rowNum = rowNum + 1
    
    ' 递归遍历子文件夹
    For Each subFolder In currentFolder.Folders
        Call TraverseFolders(subFolder, excelWB, rowNum)
    Next subFolder
    
    Set subFolder = Nothing
End Sub

使用步骤 #

1. 打开Outlook，按下Alt + F11打开VBA编辑器
2. 右键点击左侧的Project面板，选择插入 -> 模块
3. 将上面的代码粘贴到模块窗口中
4. 修改代码里的根文件夹路径（根据你的实际需求选择示例1或示例2）
5. 按下F5运行宏，或者回到Outlook，通过开发工具 -> 宏选择WeeklyFolderMailCount运行

注意事项 #

• 首次运行可能会触发Outlook的宏安全提示，需要你允许宏运行（可以在Outlook选项里调整宏安全级别为"启用所有宏"，或者添加信任位置）
• 如果你的Outlook配置了多个邮箱账号，要确保根文件夹的路径指向正确的邮箱
• 代码里的本周起始是周一，如果你需要从周日开始，把vbMonday改成vbSunday即可

内容的提问来源于stack exchange，提问作者AJames