如何遍历工作簿所有工作表并汇总到期数据生成Outlook邮件？

问题描述 #

需要根据每个工作表中的到期日期，收集工作簿内所有选中工作表的数据并汇总写入邮件。当前代码对单个选中工作表有效，但选中多个工作表时，只会重复复制单个工作表的数据。

原代码 #

Sub Followup()

Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)

Dim ws As Worksheet
Dim DateDueCol As Range
Dim DateDue As Range
Dim NotificationMsg As String
Set DateDueCol = Range("R2:R100")

For Each ws In ActiveWindow.SelectedSheets

    For Each DateDue In DateDueCol
        If DateDue <> "" And Date >= DateDue + Range("AC1") Then
            NotificationMsg = NotificationMsg & "<br>" & DateDue.Offset(0, -16) & " " & DateDue.Offset(0, -13) & " " & "CL#- " & DateDue.Offset(0, -11) & " " & "DOS- " & DateDue.Offset(0, -10)
        End If
    Next DateDue

Next ws

EmailItem.To = "xxxxxxxxxxxxxxxxxxxxxxxxxxx "

EmailItem.Subject = "CLAIMS CROSSED THE FOLLOW-UP DUE DATE"

EmailItem.HTMLBody = "Hi," & "<br>" & "<br>" & "The following claims need chasing today: " & "<br>" & NotificationMsg & _
  "<br>" & "<br>" & _
  "Regards," & "<br>" & _
  "<br>" & "xxxxxxxxxx" & _
  "<br>" & " "

EmailItem.Display

End Sub

问题原因 #

代码中Range("R2:R100")和Range("AC1")未指定所属工作表对象，默认会引用当前活动工作表的数据。因此遍历多个选中工作表时，始终读取同一个活动表的内容，导致重复单表数据。

修正后的代码 #

Sub Followup()

Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)

Dim ws As Worksheet
Dim DateDueCol As Range
Dim DateDue As Range
Dim NotificationMsg As String

' 遍历每个选中的工作表
For Each ws In ActiveWindow.SelectedSheets
    ' 指定当前工作表的到期日期列
    Set DateDueCol = ws.Range("R2:R100")
    
    ' 遍历当前工作表的到期日期单元格
    For Each DateDue In DateDueCol
        ' 引用当前工作表的AC1单元格，避免使用活动表数据
        If DateDue <> "" And Date >= DateDue.Value + ws.Range("AC1").Value Then
            ' 追加当前工作表的符合条件的数据，添加工作表名称区分来源
            NotificationMsg = NotificationMsg & "<br>" & "【" & ws.Name & "】" & DateDue.Offset(0, -16).Value & " " & DateDue.Offset(0, -13).Value & " " & "CL#- " & DateDue.Offset(0, -11).Value & " " & "DOS- " & DateDue.Offset(0, -10).Value
        End If
    Next DateDue
Next ws

EmailItem.To = "xxxxxxxxxxxxxxxxxxxxxxxxxxx "
EmailItem.Subject = "CLAIMS CROSSED THE FOLLOW-UP DUE DATE"
EmailItem.HTMLBody = "Hi," & "<br>" & "<br>" & "The following claims need chasing today: " & "<br>" & NotificationMsg & _
  "<br>" & "<br>" & _
  "Regards," & "<br>" & _
  "<br>" & "xxxxxxxxxx" & _
  "<br>" & " "

EmailItem.Display

End Sub

关键修正点 #

• 所有Range对象前添加ws.前缀，明确指定为当前循环的工作表，避免默认引用活动表
• 为单元格读取添加.Value属性，让代码逻辑更清晰（VBA中可省略，但显式写出更易维护）
• 添加ws.Name到通知内容中，方便区分数据来自哪个工作表

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