Excel VBA到期日提醒宏求助：新增到期日需手动重运行才生效

我懂你的困扰——手动运行宏才能触发提醒，新增数据后没法自动检查对吧？下面给你几个实用的解决方案，还会优化原宏的小问题，让它更灵活好用：

一、先优化原宏的两个小缺陷 #

原宏有两处可以改进的地方，先调整一下：

1. 变量声明不严谨：原代码里只有Email_Body被声明为String，其他邮件相关变量都是默认的Variant，得统一声明类型；
2. 固定单元格范围：原宏只检查A361:A370，新增数据后范围不会自动扩展，改成动态范围更省心。

优化后的宏代码：

Option Explicit
Sub SendExpiryReminder()
    Dim r As Range
    Dim cell As Range
    ' 动态获取A列从A361开始的所有非空单元格范围
    Set r = Range("A361", Range("A" & Rows.Count).End(xlUp))
    
    For Each cell In r
        ' 先检查单元格是否为日期类型，避免非日期值报错
        If IsDate(cell.Value) Then
            If Date - cell.Value = 30 Then
                Dim Email_Subject As String, Email_Send_From As String
                Dim Email_Send_To As String, Email_Cc As String
                Dim Email_Bcc As String, Email_Body As String
                Dim Mail_Object As Object, Mail_Single As Object
                
                Email_Subject = "到期日提醒：还有30天到期"
                Email_Send_From = "rdube02@gmail.com"
                Email_Send_To = "rdube02@gmail.com"
                Email_Cc = ""
                Email_Bcc = ""
                Email_Body = "请注意，有一项内容即将在30天后到期！"
                
                On Error GoTo debugs
                Set Mail_Object = CreateObject("Outlook.Application")
                Set Mail_Single = Mail_Object.CreateItem(0)
                With Mail_Single
                    .Subject = Email_Subject
                    .To = Email_Send_To
                    .cc = Email_Cc
                    .BCC = Email_Bcc
                    .Body = Email_Body
                    .Send
                End With
            End If
        End If
    Next
    Exit Sub
debugs:
    If Err.Description <> "" Then MsgBox "发送邮件出错：" & Err.Description
End Sub

二、实现自动触发的三种方案 #

方案1：每次打开工作簿时自动检查 #

如果希望每次打开文件就自动扫描到期日，把触发代码放到ThisWorkbook模块里：

1. 按Alt + F11打开VBA编辑器；
2. 在左侧项目窗口找到ThisWorkbook，双击打开；
3. 粘贴以下代码：

Private Sub Workbook_Open()
    ' 打开工作簿时自动运行提醒宏
    SendExpiryReminder
End Sub

方案2：新增/修改数据时自动检查 #

当你在A列新增或修改到期日数据时，立刻触发检查：

1. 在VBA编辑器里找到存放到期日的工作表（比如Sheet1），双击打开；
2. 粘贴以下代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 检查变更的单元格是否在A列（到期日列）
    If Not Intersect(Target, Me.Range("A:A")) Is Nothing Then
        ' 触发提醒检查
        SendExpiryReminder
    End If
End Sub

小贴士：如果批量粘贴数据，这个事件会多次触发，你可以根据需要添加判断逻辑，比如只在单个单元格变更时触发。

方案3：定时自动检查（比如每天上午9点） #

如果希望工作簿打开期间，每天固定时间自动检查，用Application.OnTime实现：

1. 打开ThisWorkbook模块，粘贴以下代码：

Private Sub Workbook_Open()
    ' 设置每天上午9点运行提醒宏
    Application.OnTime TimeValue("09:00:00"), "SendExpiryReminder"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ' 关闭工作簿时取消定时任务，避免下次打开报错
    On Error Resume Next
    Application.OnTime TimeValue("09:00:00"), "SendExpiryReminder", , False
End Sub

你可以把"09:00:00"改成你需要的时间，比如"14:30:00"。

最后注意事项 #

• 确保Outlook是打开状态，或者宏运行时能自动启动Outlook；
• 如果遇到宏被禁用的情况，需要在Excel设置里启用宏（文件>选项>信任中心>信任中心设置>宏设置）；
• 动态范围会自动包含A361以下的所有非空单元格，新增数据不用再手动调整范围。

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