Visual Basic Editor求助：Excel多列到期日期自动发邮件问题

没问题！我们可以轻松把你的代码扩展到支持三列到期日期的检查，还能在邮件里明确标注是哪项证件/登记即将到期，避免用户混淆。下面是具体的修改思路和完整代码示例：

核心修改思路 #

1. 用数组存储多列信息：把需要检查的列号和对应的到期项名称（比如“驾照”“护照”）存在数组里，以后要加更多列也能快速扩展，不用大改循环逻辑
2. 双层循环遍历：外层循环逐行读取用户数据，内层循环逐一检查该行的三列到期日期
3. 合并提醒内容：同一用户如果有多项即将到期的项目，统一放在一封邮件里发送，避免用户收到多封零散邮件

完整修改后的VBA代码 #

Sub CheckMultiColumnExpiryAndSendEmail()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim expiryColumns As Variant
    Dim currentDate As Date
    Dim daysUntilExpiry As Integer
    Dim emailBody As String
    Dim recipientEmail As String ' 假设邮箱存在C列，可根据你的表格调整
    Dim fullName As String
    
    ' 定义要检查的列：每个元素是(列号, 到期项名称)
    expiryColumns = Array( _
        Array(4, "驾照"), ' D列=4
        Array(5, "护照"), ' E列=5
        Array(6, "车辆登记") ' F列=6
    )
    
    ' 替换成你的工作表名称，比如"到期提醒列表"
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    currentDate = Date
    ' 假设A列是姓名列，用它来找最后一行数据
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 从第2行开始遍历（第1行是表头）
    For i = 2 To lastRow
        fullName = ws.Cells(i, "A").Value ' 读取姓名，比如约翰·史密斯
        recipientEmail = ws.Cells(i, "C").Value ' 读取用户邮箱
        emailBody = "亲爱的 " & fullName & "：" & vbCrLf & vbCrLf & "以下证件/登记即将到期，请留意：" & vbCrLf
        
        Dim hasExpiringItems As Boolean
        hasExpiringItems = False
        
        ' 循环检查三列的到期日期
        For j = LBound(expiryColumns) To UBound(expiryColumns)
            Dim colNum As Integer
            Dim itemName As String
            colNum = expiryColumns(j)(0)
            itemName = expiryColumns(j)(1)
            
            ' 先判断单元格是否是有效日期，避免出错
            If IsDate(ws.Cells(i, colNum).Value) Then
                daysUntilExpiry = ws.Cells(i, colNum).Value - currentDate
                ' 检查是否在0-30天内到期（包含当天到期和刚过期不超30天的情况）
                If daysUntilExpiry >= 0 And daysUntilExpiry <= 30 Then
                    hasExpiringItems = True
                    emailBody = emailBody & "- " & itemName & "：" & Format(ws.Cells(i, colNum).Value, "yyyy年mm月dd日") & "（还有" & daysUntilExpiry & "天到期）" & vbCrLf
                End If
            End If
        Next j
        
        ' 如果有即将到期的项目，发送邮件
        If hasExpiringItems Then
            emailBody = emailBody & vbCrLf & "请及时办理续期手续。" & vbCrLf & "感谢你的关注！"
            
            ' 调用Outlook发送邮件
            Dim olApp As Object
            Dim olMail As Object
            Set olApp = CreateObject("Outlook.Application")
            Set olMail = olApp.CreateItem(0)
            
            With olMail
                .To = recipientEmail
                .Subject = "【到期提醒】你的证件/登记即将到期"
                .Body = emailBody
                .Send ' 直接发送，改成.Display可以先预览邮件再发送
            End With
            
            ' 释放对象
            Set olMail = Nothing
            Set olApp = Nothing
        End If
    Next i
    
    MsgBox "到期检查和邮件发送完成！", vbInformation
End Sub

你需要根据自己的表格调整的地方 #

• 工作表名称：把代码里的Sheet1改成你实际的工作表名称（比如“员工到期列表”）
• 姓名/邮箱列：如果你的姓名不在A列、邮箱不在C列，修改ws.Cells(i, "A")和ws.Cells(i, "C")里的列标
• 到期日期范围：如果不想包含已过期的项目，把daysUntilExpiry >= 0去掉就行，只保留daysUntilExpiry <=30
• Outlook权限：第一次运行代码时，Outlook可能会弹出授权提示，允许即可

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