Question

我必须创建一个VBA来发送自动电子邮件（电子邮件正文将收件人链接到他负责的特定项目）。我遇到的问题是某个接收者（即置于“TO”）可以负责更多任务。我正在使用的VBA向每个任务发送电子邮件（即使该人负责更多）。如果收件人数大于1，我可以做什么来计算包含所有任务的电子邮件。我真的需要你的帮助。

<PRE>Sub SendEMail()
Dim OutApp As Object
Dim OutMail As Object
Dim lastRow As Long
Dim Ebody As String
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastRow
Ebody = "<FONT SIZE = 4 name = Arial>" & "Dear " & Cells(i, "A").Value          
& "<br>" _
& "<br>" _
& "Please note that the below mentioned projectd are in scope for reporting." & "<br>" _
& "<br>" _
& Cells(i, "C").Value & " - " & Cells(i, "E").Value & "<br>" _
& "xxxxx will investigate and action your notification according to priority and to ensure public safety." & "<br>" _
& "For further information, please phone xxxxx on 6111 and quote reference number:" & "<br>" _
& "Your original report can be seen below:" & "</Font>" & "<br>" _
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Cells(i, "B").Value
.Cc = Cells(i, "D").Value
.Subject = "Your Registration Code"
.HtmlBody = Ebody
.Attachments.Add "C:\Test\Document.docx"
.Attachments.Add "C:\Test\Document1.docx"
.SentOnBehalfOfName = "Financial@yahoo.com"
.Display
End With
Next
End Sub </pre>

Answer 1

Sub Emailer()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range, y, sbody
    Dim eml As Worksheet, bd As Worksheet
    Dim underlyingary, ISINarray, Accountarray, i

    Set eml = Sheets("Emailer"): Set bd = Sheets("Body"): Set OutApp = CreateObject("Outlook.Application")

    For Each y In eml.Range("A2:A" & eml.Range("A1000000").End(xlUp).Row)

    If eml.Range("F" & y.Row) <> "" Then
        underlyingary = Split(eml.Range("F" & y.Row), ",")
        Accountarray = Split(eml.Range("G" & y.Row), ",")
        ISINarray = Split(eml.Range("H" & y.Row), ",")
            For i = 0 To UBound(underlyingary)
                sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(underlyingary(i))) & " Account Number: " & WorksheetFunction.Proper(Trim(Accountarray(i))) & " ISIN: " & WorksheetFunction.Proper(Trim(ISINarray(i))) & "<br>" & "<br>"
            Next i
    Else
            sbody = sbody & vbNewLine & "Underlying: " & WorksheetFunction.Proper(Trim(eml.Range("C" & y.Row))) & " Account Number: " & WorksheetFunction.Proper(Trim(eml.Range("D" & y.Row))) & " ISIN: " & WorksheetFunction.Proper(Trim(eml.Range("E" & y.Row))) & "<br>"
    End If

    On Error GoTo cleanup
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = eml.Range("A" & y.Row)
                .Subject = bd.Range("B2")
                .cc = eml.Range("I" & y.Row)
                .htmlBody = bd.Range("A2") _
                    & "<br>" & "<br>" & _
                        bd.Range("A3") & _
                        Trim(eml.Range("B" & y.Row)) & _
                        bd.Range("A4") _
                    & "<br>" & "<br>" & _
                        sbody _
                    & "<br>" & _
                        bd.Range("A5") _
                    & "<br>" & "<br>" & "<li>" & _
                        bd.Range("A6").Text & "</li>" & _
                     "<br>" & "<br>" & "<li>" & _
                        bd.Range("A7").Text & "</li>" & _
                     "<br>" & "<br>" & "<li>" & _
                        bd.Range("A8").Text & "</li>" & _
                     "<br>" & "<br>" & _
                        bd.Range("A9") _
                    & "<br>" & bd.Range("A10")
                .display
            End With

            On Error GoTo 0
            Set OutMail = Nothing
    Next y
cleanup:
    Set OutApp = Nothing

End Sub

带有身体变化的自动电子邮件 - VBA

1 个答案: