Excel VBA实现按人员批量发送待办案件提醒邮件及相关问题

Hey Maria, let's tackle your Excel VBA email reminder task head-on. I've gone through your code and requirements, and here's a step-by-step fix for each of your issues, plus a fully revised working script.

1. 实现每周一自动触发邮件发送 #

有两种可靠的实现方式：

• 方式一：工作簿打开时自动检查
  在ThisWorkbook模块中添加如下代码，每次打开工作簿时，若当天是周一就自动运行发送邮件的宏：

  Private Sub Workbook_Open()
      ' Weekday(Date, vbMonday)返回1代表周一，2代表周二，以此类推
      If Weekday(Date, vbMonday) = 1 Then
          Call SendCaseReminders ' 调用主发送宏
      End If
  End Sub
  

• 方式二：Windows任务计划定时触发
  如果需要工作簿无需手动打开也能运行，可以设置Windows任务计划，定时启动Excel并执行宏。第一种方式更适合日常手动打开工作簿的场景。

2. 按人员汇总待办案件，每人一封邮件 #

用VBA的Dictionary对象实现分组：

• 遍历所有案件行，将每个邮箱对应的案件信息（编号、截止日期等）存入字典，键为邮箱地址，值为该邮箱对应的所有案件提醒文本。
• 遍历字典，为每个邮箱发送一封汇总了所有待办案件的邮件，避免重复发送。

3. 在邮件正文中插入单元格内容 #

直接用字符串拼接即可，支持纯文本或HTML格式（后者更美观）：

' 纯文本格式示例
bodyText = "Dear " & engineerName & "," & vbCrLf & vbCrLf
bodyText = bodyText & "Here are your pending cases:" & vbCrLf & vbCrLf
bodyText = bodyText & "- Case ID: " & Cells(x, 1).Value & " | Due Date: " & Format(Cells(x, 3).Value, "yyyy-mm-dd") & vbCrLf

' HTML格式示例（适合更美观的排版）
htmlBody = "<p>Dear " & engineerName & ",</p>"
htmlBody = htmlBody & "<p>Here are your pending cases due soon:</p>"
htmlBody = htmlBody & "<ul>"
htmlBody = htmlBody & "<li>Case ID: " & Cells(x, 1).Value & " | Due Date: " & Format(Cells(x, 3).Value, "yyyy-mm-dd") & "</li>"
htmlBody = htmlBody & "</ul>"

4. 仅发送状态为"design"的案件提醒 #

在遍历案件行时添加条件判断，跳过非目标状态的案件：

' 假设状态列是第8列（H列），请根据你的实际表格调整列号
If UCase(Cells(x, 8).Value) <> "DESIGN" Then Continue For

5. 修复Error 13（类型不匹配）错误 #

你的原代码存在几个导致类型错误的问题：

• Sub中嵌套Function：VBA不允许在Sub过程内部定义Function，需将函数逻辑整合到主Sub中，或把函数移到Sub外部。
• 错误的Set语句：daysLeft是数值型变量，不能用Set赋值，应直接写daysLeft = mydate2 - datetoday2。
• 拼写错误：Cell(x,6)应为Cells(x,6)（复数形式）。
• 变量未声明：建议在代码开头添加Option Explicit强制变量声明，避免因未声明变量导致的类型问题。

完整优化后的VBA代码 #

将以下代码粘贴到Excel的标准模块（如Module1）中：

Option Explicit
' 早期绑定：需先引用Microsoft Outlook Object Library（工具->引用->勾选对应选项）
' 后期绑定：将New Outlook.Application替换为CreateObject("Outlook.Application")，无需引用

Sub SendCaseReminders()
    Dim outlookApp As Outlook.Application
    Dim outlookMail As Outlook.MailItem
    Dim caseDict As Object ' 用于分组邮箱与案件
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim x As Long
    Dim dueDate As Date
    Dim daysLeft As Long
    Dim engineerEmail As String
    Dim engineerName As String
    Dim caseIdentifier As String
    Dim caseReminderText As String
    Dim emailBody As String
    
    ' 初始化对象
    Set ws = ThisWorkbook.Sheets("Messages english")
    Set caseDict = CreateObject("Scripting.Dictionary")
    Set outlookApp = New Outlook.Application
    
    ' 获取数据最后一行
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 遍历所有案件（从第2行开始，假设第1行是表头）
    For x = 2 To lastRow
        ' 跳过非design状态的案件（假设状态列是H列，可调整）
        If UCase(ws.Cells(x, 8).Value) <> "DESIGN" Then GoTo NextCase
        
        ' 获取关键信息
        dueDate = ws.Cells(x, 3).Value
        daysLeft = dueDate - Date
        engineerEmail = ws.Cells(x, 2).Value
        engineerName = ws.Cells(x, 6).Value
        caseIdentifier = ws.Cells(x, 1).Value & " " & ws.Cells(x, 2).Value ' 组合A、B列作为案件标识
        
        ' 仅处理未过期的案件
        If daysLeft >= 0 Then
            ' 根据剩余天数生成不同优先级的提醒文本
            Select Case daysLeft
                Case 8 To 14
                    caseReminderText = vbCrLf & "- " & caseIdentifier & " (Due in " & daysLeft & " days, " & Format(dueDate, "yyyy-mm-dd") & ") | Early Reminder"
                Case 4 To 7
                    caseReminderText = vbCrLf & "- " & caseIdentifier & " (Due in " & daysLeft & " days, " & Format(dueDate, "yyyy-mm-dd") & ") | Urgent Reminder"
                Case 0 To 3
                    caseReminderText = vbCrLf & "- " & caseIdentifier & " (Due NOW/OVERDUE! Date: " & Format(dueDate, "yyyy-mm-dd") & ") | Critical Reminder"
                Case Else
                    caseReminderText = vbCrLf & "- " & caseIdentifier & " (Due in " & daysLeft & " days, " & Format(dueDate, "yyyy-mm-dd") & ")"
            End Select
            
            ' 将案件信息添加到字典
            If caseDict.Exists(engineerEmail) Then
                caseDict(engineerEmail) = caseDict(engineerEmail) & caseReminderText
            Else
                caseDict(engineerEmail) = "Dear " & engineerName & "," & vbCrLf & vbCrLf & "Here are your pending cases this week:" & caseReminderText
            End If
            
            ' 标记已发送提醒（对应原代码的10/11/12列）
            Select Case daysLeft
                Case 8 To 14
                    With ws.Cells(x, 10)
                        .Value = Date
                        .Interior.ColorIndex = 3
                        .Font.ColorIndex = 2
                        .Font.Bold = True
                    End With
                Case 4 To 7
                    With ws.Cells(x, 11)
                        .Value = Date
                        .Interior.ColorIndex = 3
                        .Font.ColorIndex = 2
                        .Font.Bold = True
                    End With
                Case 0 To 3
                    With ws.Cells(x, 12)
                        .Value = Date
                        .Interior.ColorIndex = 3
                        .Font.ColorIndex = 2
                        .Font.Bold = True
                    End With
            End Select
        End If
NextCase:
    Next x
    
    ' 发送汇总邮件
    For Each engineerEmail In caseDict.Keys
        Set outlookMail = outlookApp.CreateItem(olMailItem)
        With outlookMail
            .To = engineerEmail
            .Subject = "Weekly Pending Case Reminder - " & Format(Date, "yyyy-mm-dd")
            .Body = caseDict(engineerEmail) & vbCrLf & vbCrLf & "Best regards," & vbCrLf & "Your Team"
            .Display ' 测试阶段用Display查看邮件，正式使用时改为.Send
        End With
        Set outlookMail = Nothing
    Next engineerEmail
    
    ' 清理对象
    Set caseDict = Nothing
    Set outlookApp = Nothing
    MsgBox "Reminder emails processed successfully!", vbInformation
End Sub

注意事项： #

1. 调整列号：根据你的实际表格结构，修改代码中对应的列索引（如状态列、邮箱列等）。
2. Outlook绑定：若使用早期绑定，需在VBA编辑器中引用Outlook库；若用后期绑定，替换New Outlook.Application为CreateObject("Outlook.Application")即可。
3. 测试验证：先保留.Display测试邮件内容，确认无误后再改为.Send自动发送。

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