excel 为每个地址发送单个提醒电子邮件，而不是多个电子邮件

pinkon5k 于 2023-08-08 发布在其他

关注(0)|答案(1)|浏览(130)

我有一个脚本，发送电子邮件提醒人们重新认证。
电子表格设置：

的数据
如果用户的证书即将过期，或者他们的证书已经过期，脚本将向他们的地址发送电子邮件。这部分工作。
真实的用例电子表格（我不能分享）有大约30个操作员和50台机器。给每个人发送超过15封电子邮件是不明智的。
如何发送一封列出所有要重新认证的设备的电子邮件？

Sub AutoMailer()
Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
Dim RList As Range
Set RList = Range("C4", "BZ50")
Dim R As Range
For Each R In RList
    If IsEmpty(R) = False Then
        If (DateDiff("d", R.Value, Now)) >= 335 And (DateDiff("d", R.Value, Now)) < 365 Then
            R.Interior.ColorIndex = 27 'Change color to yellow
            Set EItem = EApp.CreateItem(0)
            With EItem
                .To = R.Offset(, -(R.Column - 2))
              
                .Subject = "You're due for retraining and certification"
                .Body = "Hello, " & R.Offset(, -(R.Column - 1)) & vbNewLine & vbNewLine _
                  & "Your certification with the " & R.Offset((-(R.Row - 3)), 0) & " has almost expired. You have " & (365 - (DateDiff("d", R.Value, Now))) & " days until it expires."
                .Display
            End With
        ElseIf (DateDiff("d", R.Value, Now)) > 365 Then
            R.Interior.ColorIndex = 3 'Change color to red
            Set EItem = EApp.CreateItem(0)
            With EItem
                .To = R.Offset(, -(R.Column - 2))
                
                .Subject = "You're overdue for retraining and certification"
                .Body = "Hello, " & R.Offset(, -(R.Column - 1)) & vbNewLine & vbNewLine _
                  & "Your certification with the " & R.Offset((-(R.Row - 3)), 0) & " has expired. You are " & ((DateDiff("d", R.Value, Now)) - 365) & " days overdue for retraining."
                .Display
            End With
        End If
    End If
Next

Set EApp = Nothing
Set EItem = Nothing
End Sub

字符串
有没有一种方法，而不是看每个单元格，看行，阅读哪些单元格是过时的，然后构建一个电子邮件。

excel

来源：https://stackoverflow.com/questions/76766269/sending-a-single-reminder-email-for-each-address-instead-of-multiple-emails

1条答案

按热度按时间

vxqlmq5t1#

你的建议很好，创建一个外部循环来遍历每个名称，创建一个内部循环来遍历该行中的每个设备。
不要为每个设备创建新的电子邮件，而是将每个设备添加到变量中。然后在最后使用变量创建您的电子邮件。
我已经尽可能少地修改了你的代码。我添加了一个外部循环来遍历列A中的名称，并添加了一个变量来检查主题是due还是overdue。如果不重新创建工作表，很难进行测试，但给予尝试一下：

Sub AutoMailer()
Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
Dim RList As Range
Set RList = Range("C4", "BZ50")
Dim R As Range
Dim sBody As String
Dim RNames As Range, RName As Range
Set RNames = Range("A4", "A50")
Dim sOverdue As String

'Loop through names
For Each RName In RNames
If IsEmpty(RName) = False Then

sOverdue = "due"
    
    'Loop through equipment in current row
    For Each R In Intersect(RList, RName.EntireRow)
        If IsEmpty(R) = False Then
            If (DateDiff("d", R.Value, Now)) >= 335 And (DateDiff("d", R.Value, Now)) < 365 Then
                R.Interior.ColorIndex = 27 'Change color to yellow
                sBody = sBody & vbNewLine & _
                    "Your certification with the " & R.Offset((-(R.Row - 3)), 0) & " has almost expired. You have " & (365 - (DateDiff("d", R.Value, Now))) & " days until it expires."
                
            ElseIf (DateDiff("d", R.Value, Now)) > 365 Then
                R.Interior.ColorIndex = 3 'Change color to red
                sOverdue = "overdue" 'Change message to overdue
                sBody = sBody & vbNewLine & _
                    "Your certification with the " & R.Offset((-(R.Row - 3)), 0) & " has expired. You are " & ((DateDiff("d", R.Value, Now)) - 365) & " days overdue for retraining."

            End If
        End If
    Next
    
    'Create email
    Set EItem = EApp.CreateItem(0)
    With EItem
      .To = RName.Offset(0, 1)
      .Subject = "You're " & sOverdue & " for retraining and certification"
      .body = "Hello, " & RName & vbNewLine & vbNewLine & sBody
      .Display
    End With
   
    Set EApp = Nothing
    Set EItem = Nothing
        
Next RName

End Sub

字符串

赞(0）回复(0）举报 2023-08-08

我来回答

excel 为每个地址发送单个提醒电子邮件，而不是多个电子邮件

1条答案

相关问题

热门标签

最新问答