Excel数组日期检测及自动发送复训提醒邮件的VBA开发问题

需求说明 #

• 表格结构：左列为人员姓名，顶部行为设备名称，交叉单元格存储对应人员的设备认证日期
• 触发条件：当认证日期距离当前日期处于**335-365天内（即将过期）或超过365天（已过期）**时，自动发送提醒邮件
• 额外要求：邮件内容需明确标注需复训的设备名称

原列表版代码局限性 #

原列表版代码依赖列偏移逻辑（R.Offset(,3)），仅适用于单设备单记录的列表结构，无法处理多设备跨行列的数组式表格，也无法关联人员对应的具体过期设备。

数组结构适配版VBA代码 #

Sub EquipmentCertReminder()
    Dim olApp As Object
    Dim olMail As Object
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim daysDiff As Long
    Dim toEmail As String, userName As String
    Dim expiringEquips As String, overdueEquips As String
    
    ' 设置目标工作表（可根据实际修改）
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ' 获取表格有效行列范围
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 初始化Outlook对象
    Set olApp = CreateObject("Outlook.Application")
    
    ' 遍历每一位人员（从第2行开始，第1行是设备名称）
    For i = 2 To lastRow
        userName = ws.Cells(i, 1).Value
        toEmail = ws.Cells(i, 2).Value ' 假设第2列是人员邮箱，可根据实际调整
        expiringEquips = ""
        overdueEquips = ""
        
        ' 遍历该人员的所有设备认证日期（从第3列开始，第1列姓名，第2列邮箱）
        For j = 3 To lastCol
            ' 跳过空日期单元格
            If IsDate(ws.Cells(i, j).Value) Then
                daysDiff = DateDiff("d", ws.Cells(i, j).Value, Now)
                
                ' 判断日期范围，收集对应设备
                If daysDiff >= 335 And daysDiff < 365 Then
                    expiringEquips = expiringEquips & "- " & ws.Cells(1, j).Value & vbNewLine
                ElseIf daysDiff > 365 Then
                    overdueEquips = overdueEquips & "- " & ws.Cells(1, j).Value & vbNewLine
                End If
            End If
        Next j
        
        ' 有即将过期的设备时发送提醒邮件
        If expiringEquips <> "" Then
            Set olMail = olApp.CreateItem(0)
            With olMail
                .To = toEmail
                .Subject = "【提醒】您的设备认证即将到期，请及时复训"
                .Body = "您好，" & userName & vbNewLine & vbNewLine _
                      & "以下设备的认证即将到期，请尽快完成复训：" & vbNewLine & vbNewLine _
                      & expiringEquips & vbNewLine _
                      & "距离到期剩余天数：" & (365 - daysDiff) & "天"
                .Send ' 测试阶段可改为.Display查看邮件内容
            End With
            Set olMail = Nothing
        End If
        
        ' 有已过期的设备时发送逾期提醒邮件
        If overdueEquips <> "" Then
            Set olMail = olApp.CreateItem(0)
            With olMail
                .To = toEmail
                .Subject = "【警告】您的设备认证已逾期，请立即复训"
                .Body = "您好，" & userName & vbNewLine & vbNewLine _
                      & "以下设备的认证已逾期，请立即完成复训：" & vbNewLine & vbNewLine _
                      & overdueEquips & vbNewLine _
                      & "逾期天数：" & (daysDiff - 365) & "天"
                .Send ' 测试阶段可改为.Display查看邮件内容
            End With
            Set olMail = Nothing
        End If
    Next i
    
    ' 释放对象
    Set olApp = Nothing
    MsgBox "提醒邮件发送完成！", vbInformation
End Sub

代码关键逻辑说明 #

• 行列遍历：通过双重循环遍历人员行和设备列，实现数组式表格的跨行列比对
• 设备关联：通过ws.Cells(1, j).Value获取当前列对应的设备名称，确保邮件中明确标注需复训的设备
• 分类收集：为每个人员分别收集即将过期和已过期的设备，避免重复发送邮件
• 灵活适配：可通过修改ws、toEmail所在列等参数，适配不同的表格结构

使用注意事项 #

• 确保Excel表格中第1行为设备名称，第1列为人员姓名，第2列为人员邮箱（可根据实际调整代码中的列索引）
• 测试阶段建议将.Send改为.Display，确认邮件内容无误后再切换为发送
• 运行代码前需确保Outlook已正常打开，且具备发送邮件的权限

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