Excel VBA技术咨询：单元格重放循环与到期邮件提醒故障修复

问题一：如何从不同单元格创建重放循环？ #

这里的重放循环指基于多个单元格内容重复执行指定操作的循环，以下是两种实用实现方式：

• 遍历指定单元格区域：用For Each循环逐个处理目标区域内的单元格，适合明确知道处理范围的场景。示例代码：

Sub 单元格重放循环()
    Dim targetCell As Range
    ' 遍历A1到A10的单元格
    For Each targetCell In Range("A1:A10")
        If targetCell.Value <> "" Then
            ' 这里写要重复执行的操作，比如打印单元格内容
            Debug.Print "处理单元格：" & targetCell.Address & "，内容：" & targetCell.Value
        End If
    Next targetCell
End Sub

• 动态遍历非空单元格：用Do While循环从起始单元格开始，向下/向右遍历直到遇到空单元格，适合不确定数据行数/列数的场景。示例代码：

Sub 动态重放循环()
    Dim currentCell As Range
    Set currentCell = Range("A1") ' 起始单元格
    
    Do While currentCell.Value <> ""
        ' 执行重复操作，比如计算单元格值的平方
        currentCell.Offset(0, 1).Value = currentCell.Value ^ 2
        Set currentCell = currentCell.Offset(1, 0) ' 移动到下一行单元格
    Loop
End Sub

问题二：文档到期管控系统VBA代码修复与优化 #

现有代码的核心问题 #

1. 到期判断逻辑错误：用固定单元格F14/F15的值做判断，未根据每行的「提前提醒天数」计算实际到期剩余天数，导致未到期文档被误判。
2. 收件人固定：硬编码取N14/O14的邮箱，没有对应到每行的分析师和主管邮箱。
3. 未实现按分析师汇总邮件：每符合条件就发一封邮件，未将同一分析师的到期文档合并发送。

修复优化后的代码 #

Sub 到期预警邮件汇总发送()
    Dim outlookApp As Outlook.Application
    Dim mailItem As Outlook.MailItem
    Dim docDict As Object ' 用于按分析师分组存储文档信息
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim currentDate As Date
    Dim daysToExpire As Long
    Dim analystEmail As String
    Dim managerEmail As String
    Dim docInfo As String
    Dim key As Variant
    
    Set ws = ThisWorkbook.ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 获取数据最后一行
    currentDate = Date ' 当前日期
    Set docDict = CreateObject("Scripting.Dictionary") ' 创建字典分组
    
    ' 遍历表格数据，收集符合条件的到期文档
    For i = 2 To lastRow ' 假设第一行是表头，从第二行开始遍历
        If IsDate(ws.Cells(i, "B").Value) Then ' 确保到期日期是有效日期
            ' 计算到期剩余天数：到期日期 - 当前日期
            daysToExpire = ws.Cells(i, "B").Value - currentDate
            ' 判断是否满足提前提醒条件：剩余天数 ≤ 提前提醒天数，且剩余天数≥0（未过期）
            If daysToExpire >= 0 And daysToExpire <= ws.Cells(i, "C").Value Then
                analystEmail = ws.Cells(i, "E").Value
                managerEmail = ws.Cells(i, "F").Value
                ' 整理单条文档的预警信息
                docInfo = "<br>- 文档名称：" & ws.Cells(i, "A").Value & _
                          "，文档类型：" & ws.Cells(i, "D").Value & _
                          "，到期剩余天数：" & daysToExpire & "天"
                
                ' 按分析师邮箱分组存储，同时记录主管邮箱
                If docDict.Exists(analystEmail) Then
                    ' 已有该分析师，追加文档信息
                    docDict(analystEmail) = docDict(analystEmail) & docInfo
                Else
                    ' 新增分析师，存储文档信息和主管邮箱（用|分隔）
                    docDict(analystEmail) = managerEmail & "|" & docInfo
                End If
            End If
        End If
    Next i
    
    ' 初始化Outlook应用
    Set outlookApp = New Outlook.Application
    
    ' 遍历字典，给每个分析师发送汇总邮件
    For Each key In docDict.Keys
        Set mailItem = outlookApp.CreateItem(olMailItem)
        ' 拆分主管邮箱和文档信息
        managerEmail = Split(docDict(key), "|")(0)
        docInfo = Split(docDict(key), "|")(1)
        
        With mailItem
            .BodyFormat = olFormatHTML
            .To = key ' 分析师邮箱
            .CC = managerEmail ' 主管邮箱
            .Subject = "文档到期预警汇总"
            .HTMLBody = "您好，以下是您负责的即将到期的文档列表：" & docInfo & "<br><br>请及时处理。"
            .Send ' 直接发送，如需测试可改为.Display
        End With
    Next key
    
    Set mailItem = Nothing
    Set outlookApp = Nothing
    Set docDict = Nothing
    MsgBox "到期预警邮件已全部发送完成"
End Sub

代码说明 #

• 分组逻辑：用字典Scripting.Dictionary按分析师邮箱作为键，存储对应的主管邮箱和所有到期文档信息，实现同一分析师的文档汇总。
• 到期判断：计算当前日期到到期日期的剩余天数，仅当剩余天数≥0且≤该行的「提前提醒天数」时，才纳入预警范围。
• 收件人动态匹配：直接取每行对应的分析师邮箱和主管邮箱，避免硬编码。

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