Question

我正在尝试向个人收件人发送电子邮件提醒及其关联的用户ID，以便他们完成调查。每个收件人可以拥有多个userID。只有在收件人未完成调查时才会触发电子邮件提醒。

问题是所有提醒都包含来自尚未发送回复的其他收件人的所有用户ID。我该如何解决这个问题？谢谢。

Sub SendReminderMail()
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim iCounter As Integer
    Dim MailDest As String
    Dim DGName As String 

    Set OutLookApp = CreateObject("OutLook.Application")
    Set OutLookMailItem = OutLookApp.CreateItem(0)
    With OutLookMailItem
    MailDest=""

    For iCounter =1 to WorksheetFunction.CountA(Columns(16))
        If MailDest =""And Cells(iCounter,14) = "" Then
            MailDest = Cells(iCounter,16).Value
            DGName = Cells(iCounter,12).Value
        ElseIf  MailDest<>  ""  And  Cells(iCounter,14)="" Then
            MailDest = MailDest & ";" & Cells(iCounter,16)
            DGName = DGName & ";" & Cells(iCounter,12)
        End If
    Next iCounter

    .BCC =  MailDest
    .Subject =
    .HTMLBody = "Message" & "<br/><br/>" & DGName & "<br/><br/>" & "Message"

Answer 1

Sub SendReminderMail2()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
Dim DGName() As String 'each user can have multiple usernames
    Dim DGNamecounter As Long
ReDim usedmaildest(0)
    Dim usedMailcounter As Long
    Dim emailused As Boolean

Set OutLookApp = CreateObject("OutLook.Application")

For iCounter = 2 To WorksheetFunction.CountA(Columns(16)) 'from the second column to the end
    If Cells(iCounter, 14) = "Yes" Then 'if it needs feedback
        MailDest = Cells(iCounter, 16)
        For j = LBound(usedmaildest) To UBound(usedmaildest) 'if the email has been sent
            If MailDest = usedmaildest(j) Then emailused = True 'then mark this line as redundant
        Next j
        If Not emailused Then 'and abort further processing, otherwise:
            ReDim Preserve usedmaildest(usedMailcounter) 'increase the used email addresses array if necessary
            usedmaildest(usedMailcounter) = MailDest 'add the current email address to the used ones
            usedMailcounter = usedMailcounter + 1 'increase the counter of the used mail addresses
            'then we need to find all the usernames for this email address

            For k = iCounter To WorksheetFunction.CountA(Columns(16)) 'look from the current row down
                If Cells(k, 14) = "Yes" And Cells(k, 16) = MailDest Then 'if it's the same email and needs feedback
                    ReDim Preserve DGName(DGNamecounter) 'increase the username array if necessary
                    DGName(DGNamecounter) = Cells(k, 12) 'add the current username to the array
                    DGNamecounter = DGNamecounter + 1 'increase the array counter
                End If
            Next k
            'sending the email
            Set OutLookMailItem = OutLookApp.CreateItem(0)
            With OutLookMailItem
                .BCC = MailDest
                .Subject = "Account feedback"
                'we insert all the usernames relating to the email address
                .HTMLBody = "This email is concerning username" & IIf(DGNamecounter = 1, "", "s") & "<br/><br/>" & Join(DGName, "<br/>") & "<br/><br/>" & "Message"
                .Display
                '.Send
            End With

            DGNamecounter = 0 ' reducing the array counter to 0

        End If
        emailused = False ' set your boolean back to default
    End If
Next iCounter

End Sub

我想您希望每个地址都能收到一封电子邮件，其中包含他们提供反馈所需的每个用户名这个宏在向您介绍数组的同时做到了这一点。

Answer 2

这个简短的示例向您展示了如何为示例数据的每个邮件地址收集用户ID。您需要在我发表评论的地方发送您的电子邮件。

Option Explicit

Sub example()

    Dim DGName As String

    Dim MailDest As String
    MailDest = Cells(2, 16) 'initialize

    Dim iCounter As Long
    For iCounter = 2 To WorksheetFunction.CountA(Columns(16)) + 1
        If Cells(iCounter, 14) = vbNullString Then
            If MailDest = Cells(iCounter, 16) Then
                DGName = IIf(DGName <> vbNullString, DGName & ";", vbNullString) & Cells(iCounter, 12)
            ElseIf MailDest <> vbNullString Then
                Debug.Print "SendMail to " & MailDest, DGName
                'send your email here
                DGName = Cells(iCounter, 12)
                MailDest = Cells(iCounter, 16)
            End If
        End If
    Next iCounter

End Sub

从列表中向单个收件人发送唯一提醒电子邮件

2 个答案: