如何在一封邮件中发送VBA代码返回的多个值？

需求目标 #

通过VBA代码发送包含所有符合条件返回值的单封邮件，替代原本多封单值邮件的发送方式。

问题现状 #

当前代码仅将最后一个符合条件的返回值放入邮件内容，且会向同一邮箱发送多封仅含单个值的邮件，无法满足“一封邮件汇总所有结果”的需求。

代码逻辑说明 #

遍历G列（从G5开始到最后一行有数据的单元格），当对应行的H列单元格为空时，提取该行的D列与F列值拼接为客户信息；需要将所有符合条件的客户信息汇总到一封邮件中发送。

原代码 #

Sub Email()

Dim Outlook, OutApp, OutMail As Object
Dim EmailSubject As String, EmailSendTo As String, MailBody As String
Dim SigString As String, Signature As String, fpath As String
Dim Quarter As String, client() As Variant
Dim Alert As Date, Today As Date, Days As Integer, Due As Integer

Set Outlook = OpenOutlook

Quarter = Range("G4").Value
Set rng = Range(Range("G5"), Range("G" & Rows.Count).End(xlUp))

'Resize Array prior to loading data
ReDim client(rng.Rows.Count)

'Check column G for blank cells and return F cells
For Each Cell In rng
    If Cell.Offset(0, 1).Value = "" Then
        ReDim client(x)
        Alert = Cell.Offset(0, 0).Value
        Today = Format(Now(), "dd-mmm-yy")
        Days = Alert - Today
        Due = Days * -1
        client(x) = Cell.Offset(0, -3).Value & " " & Cell.Offset(0, -1).Value
    End If
Next
    For x = LBound(client) To UBound(client)
        List = client(x) & vbNewLine
        List = List + List
    Next x
        
'Check dates to send subject line'
    If Days < 0 Then
        mail = True
        EmailSubject = Quarter & " Vat Returns are Overdue"
        MailBody = "<p>The Vat Returns are overdue by " & Due & " Days. See the clients below: </p>" & List
    ElseIf Days <= 14 Then
        mail = True
        EmailSubject = "Vat Returns are due within Two weeks"
        MailBody = "<p>The Vat Returns are due in " & Days & " Days. See the clients below: </p>" & List
    End If
  
'Fetch signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\.htm"
    Signature = GetBoiler(SigString)
    
'Fetch link for file location
    fpath = "K:
    
'Skip if mail=false
    If mail = True Then
    
'Send Mail
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(o)
        With OutMail
            .Subject = EmailSubject
            .To = ""
            '.bcc
            sHTML = "<HTML><BODY>"
            sHTML = sHTML & "<p>Hi, </p>"
            sHTML = sHTML & MailBody
            sHTML = sHTML & "<p>If the Vat Return have been filed, please update the database using the link below.</p>"
            sHTML = sHTML & "<A href='" & fpath & "'></A>"
            sHTML = sHTML & "<p>Regards,</p>"
            .HTMLBody = sHTML & Signature
            .HTMLBody = .HTMLBody & "</BODY></HTML>"
            .Display
        End With
        
        Set Outlook = Nothing
        Set OutMail = Nothing
        Set OutApp = Nothing
        
        mail = False
        EmailSendTo = ""
        
    End If

End Sub

修改后的代码 #

Sub Email()

Dim Outlook, OutApp, OutMail As Object
Dim EmailSubject As String, EmailSendTo As String, MailBody As String
Dim SigString As String, Signature As String, fpath As String
Dim Quarter As String, client() As Variant
Dim Alert As Date, Today As Date, Days As Integer, Due As Integer
Dim x As Integer, hasClients As Boolean

Set Outlook = OpenOutlook

Quarter = Range("G4").Value
Set rng = Range(Range("G5"), Range("G" & Rows.Count).End(xlUp))

'初始化计数器与数组
x = 0
ReDim client(0 To rng.Rows.Count - 1)
hasClients = False
Today = Date '直接获取当前日期，无需格式化

'遍历G列，收集所有符合条件的客户信息
For Each Cell In rng
    If Cell.Offset(0, 1).Value = "" Then
        hasClients = True
        Alert = Cell.Value
        Days = Alert - Today
        '仅首次记录日期判断值，如需按不同日期分类可调整逻辑
        If x = 0 Then
            Due = Days * -1
        End If
        '拼接客户信息并存入数组
        client(x) = Cell.Offset(0, -3).Value & " " & Cell.Offset(0, -1).Value
        x = x + 1
    End If
Next

'有符合条件的客户才构建邮件
If hasClients Then
    '调整数组到实际元素数量
    ReDim Preserve client(0 To x - 1)
    
    '构建HTML格式的客户列表
    Dim clientList As String
    clientList = "<ul>"
    For x = LBound(client) To UBound(client)
        clientList = clientList & "<li>" & client(x) & "</li>"
    Next x
    clientList = clientList & "</ul>"
    
    '根据日期确定邮件主题与内容
    If Days < 0 Then
        EmailSubject = Quarter & " 增值税申报已逾期"
        MailBody = "<p>增值税申报已逾期 " & Due & " 天，涉及客户如下：</p>" & clientList
    ElseIf Days <= 14 Then
        EmailSubject = "增值税申报将于两周内到期"
        MailBody = "<p>增值税申报将于 " & Days & " 天后到期，涉及客户如下：</p>" & clientList
    End If
    
    '获取Outlook签名
    SigString = Environ("appdata") & "\Microsoft\Signatures\"
    SigString = Dir(SigString & "*.htm")
    If SigString <> "" Then
        Signature = GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & SigString)
    Else
        Signature = "" '无签名则为空
    End If
    
    '补充完整文件路径
    fpath = "K:\Your\Full\File\Path\Here" '替换为实际路径
    
    '创建并发送邮件
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0) '0代表olMailItem
    With OutMail
        .Subject = EmailSubject
        .To = "" '填写收件人邮箱
        '.Bcc = "" '如需密送可添加
        
        '构建HTML邮件内容
        Dim sHTML As String
        sHTML = "<HTML><BODY>"
        sHTML = sHTML & "<p>您好：</p>"
        sHTML = sHTML & MailBody
        sHTML = sHTML & "<p>若增值税申报已完成，请通过下方链接更新数据库：</p>"
        sHTML = sHTML & "<a href='" & fpath & "'>数据库更新链接</a>"
        sHTML = sHTML & "<p>此致，</p>"
        .HTMLBody = sHTML & Signature & "</BODY></HTML>"
        .Display '如需直接发送可改为.Send
    End With
    
    '释放对象
    Set Outlook = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
End If

End Sub

修改说明 #

1. 数组处理优化：

   • 新增计数器x累加存储符合条件的客户信息，避免每次遍历清空数组
   • 使用ReDim Preserve调整数组到实际元素数量，去除空值

2. 客户列表构建：

   • 改用HTML列表标签<ul><li>构建格式清晰的客户清单
   • 修复原代码中List = List + List的错误拼接逻辑，改为逐行累加

3. 日期逻辑修正：

   • 统一在遍历前获取当前日期，避免重复计算
   • 仅首次记录日期差值，如需按不同客户日期分类发送可进一步调整

4. 代码细节修复：

   • 补充fpath的完整路径，原代码路径不完整
   • 修正CreateItem(o)为CreateItem(0)（Outlook邮件项的正确参数）
   • 完善签名获取逻辑，处理无签名的场景
   • 添加hasClients判断，仅当有符合条件的客户时才触发邮件发送

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