自动筛选含当日日期的整行并发送提醒邮件的VBA宏需求

改进后的完整VBA代码 #

Sub AutoEmailDailyRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim filterRange As Range
    Dim visibleRows As Range
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim mailBody As Object
    
    ' 关闭屏幕更新，提升运行效率
    Application.ScreenUpdating = False
    
    ' 设置目标工作表（根据实际情况修改工作表名称）
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' 清除之前的筛选
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    ' 获取D列最后一行行号
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
    
    ' 设置筛选范围（假设表头在第1行）
    Set filterRange = ws.Range("A1:D" & lastRow)
    
    ' 筛选D列等于当日日期的行
    filterRange.AutoFilter Field:=4, Criteria1:=Date
    
    ' 获取筛选后的可见行（排除表头）
    On Error Resume Next
    Set visibleRows = filterRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
    On Error GoTo 0
    
    ' 创建Outlook邮件
    Set outlookApp = CreateObject("Outlook.Application")
    Set outlookMail = outlookApp.CreateItem(0)
    
    With outlookMail
        .To = "指定收件人邮箱@xxx.com" ' 修改为实际收件人邮箱
        .CC = "抄送邮箱@xxx.com" ' 修改为实际抄送邮箱
        .Subject = "每日提醒：" & Format(Date, "yyyy-mm-dd") & "待处理事项"
        
        ' 初始化邮件正文编辑器
        .BodyFormat = 2 ' olFormatHTML
        Set mailBody = .GetInspector.WordEditor
        
        ' 添加开头文本
        mailBody.Range.InsertBefore "您好，" & vbNewLine & "以下是今日待处理事项：" & vbNewLine & vbNewLine
        
        ' 如果有匹配的行，复制到邮件正文
        If Not visibleRows Is Nothing Then
            visibleRows.Copy
            mailBody.Range.PasteExcelTable _
                LinkedToExcel:=False, _
                WordFormatting:=True, _
                RTF:=False
        Else
            ' 没有匹配行时提示
            mailBody.Range.InsertAfter "今日无待处理事项。"
        End If
        
        ' 发送邮件（如果需要测试，可改为.Display）
        .Send
    End With
    
    ' 清除筛选
    ws.AutoFilterMode = False
    
    ' 释放对象
    Set outlookMail = Nothing
    Set outlookApp = Nothing
    Set mailBody = Nothing
    Set visibleRows = Nothing
    Set filterRange = Nothing
    Set ws = Nothing
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

代码关键说明 #

• 自动筛选逻辑：通过AutoFilter方法筛选D列（Field:=4）等于当日日期（Criteria1:=Date）的行，完全替代手动选择范围的操作。
• 可见行处理：用SpecialCells(xlCellTypeVisible)精准获取筛选后的有效数据行，自动排除表头避免冗余内容。
• 邮件正文格式化：借助Outlook的Word编辑器，将Excel表格直接粘贴为格式化的HTML内容，保证邮件排版清晰易读。
• 错误处理：添加On Error语句避免无匹配行时的运行错误，同时关闭屏幕更新提升宏的运行速度。

设置每日自动运行的方法 #

方法1：配合Windows任务计划程序（无需保持Excel运行） #

1. 给Excel文件添加打开触发宏的逻辑：打开VBA编辑器（Alt+F11），双击ThisWorkbook，输入以下代码：

   Private Sub Workbook_Open()
       AutoEmailDailyRows
       ' 执行完成后自动关闭Excel（可选）
       ThisWorkbook.Close SaveChanges:=False
   End Sub
   

2. 打开Windows任务计划程序，创建新任务：
   • 触发器设置为每日指定时间
   • 操作选择“启动程序”，程序路径选择Excel安装路径（如C:\Program Files\Microsoft Office\root\Office16\EXCEL.EXE）
   • 添加参数：/e "你的Excel文件完整路径"（示例：/e "C:\Users\xxx\Documents\待处理事项.xlsx"）

方法2：Excel内置定时任务（需保持Excel运行） #

如果需要Excel一直处于运行状态，可使用Application.OnTime方法设置每日定时触发：
在ThisWorkbook中添加以下代码：

Private Sub Workbook_Open()
    ' 设置每日8:00自动执行宏（可修改时间）
    Application.OnTime TimeValue("08:00:00"), "AutoEmailDailyRows"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ' 关闭时取消定时任务
    On Error Resume Next
    Application.OnTime TimeValue("08:00:00"), "AutoEmailDailyRows", , False
End Sub

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