在一封电子邮件中为每个用户整合Excel信息

Question

我的表格结构如下：

Vendor              Consultor   CLIENT  Date        OS      Status
[email protected]       Andrew      NAME 1  25/12/2017  123456  Pend
[email protected]       Andrew      NAME 2  31/12/2017  789123  Pend
[email protected]    Joseph      NAME 3  10/12/2017  654321  Pend

我需要整合所有待售给卖家“Andrew或Joseph”的内容，并发送一封带有“OS”列表的电子邮件。我使用以下代码但不成功，因为它为工作表的每一行打开一封新电子邮件：

Sub email()

Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

For i = 1 To Range("C5536").End(xlUp).Row
Set OutMail = OutApp.CreateItem(0)

    strto = Cells(i, 1)
    strsub = "OS - PENDING"
    strbody = "Hello," & vbCrLf & vbCrLf & _
        "Please, check your pending OS's" & vbCrLf & vbCrLf & _
        "Detalhes:" & vbCrLf & _
        "Consultor:" & Cells(i, 3) & vbCrLf & _
        "Date:" & Cells(i, 4) & vbCrLf & _
        "OS:" & Cells(i, 5) & vbCrLf & vbCrLf & _
        "Best Regards" & vbCrLf & _
        "Team"

    With OutMail
        .To = strto
        .Subject = strsub
        .Body = strbody
        .Display

    End With
    On Error Resume Next

Next

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Answer 1

使用以下代码创建类cVendorline

Option Explicit

Private mClient As String
Private mDate As Date
Private mOS As String

Public Property Get Client() As String
        Client = mClient
End Property

Public Property Let Client(ByVal bNewValue As String)
        mClient = bNewValue
End Property        

Public Property Get dDate() As Date    
    dDate = mDate    
End Property

Public Property Let dDate(ByVal bNewValue As Date)    
    mDate = bNewValue    
End Property

Public Property Get OS() As String    
    OS = mOS    
End Property

Public Property Let OS(ByVal sNewValue As String)    
    mOS = sNewValue    
End Property

然后将以下代码放入模块并运行Consolidate

Option Explicit

Sub Consolidate()

#If Early Then
    Dim emailInformation As New Scripting.Dictionary
#Else
    Dim emailInformation As Object
    Set emailInformation = CreateObject("Scripting.Dictionary")
#End If

    GetEmailInformation emailInformation
    SendInfoEmail emailInformation
End Sub

Sub GetEmailInformation(emailInformation As Object)

Dim rg As Range
Dim sngRow As Range

Dim emailAddress As String
Dim vendorLine As cVendorLine
Dim vendorLines As Collection

Set rg = Range("A1").CurrentRegion    ' Assuming the list starts in A1 and DOES NOT contain empty row
Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1)    ' Cut the headings

    For Each sngRow In rg.Rows

        emailAddress = sngRow.Cells(1, 1)

        Set vendorLine = New cVendorLine
        With vendorLine
            .Client = sngRow.Cells(1, 3)
            .dDate = sngRow.Cells(1, 4)
            .OS = sngRow.Cells(1, 5)
        End With

        If emailInformation.Exists(emailAddress) Then
            emailInformation.item(emailAddress).Add vendorLine
        Else
            Set vendorLines = New Collection
            vendorLines.Add vendorLine
            emailInformation.Add emailAddress, vendorLines
        End If

    Next

End Sub

Sub SendInfoEmail(emailInformation As Object)

Dim sBody As String
Dim sBodyStart As String
Dim sBodyInfo As String
Dim sBodyEnd As String
Dim emailAdress As Variant
Dim colLines As Collection
Dim line As Variant

    sBodyStart = "Hello," & vbCrLf & vbCrLf & _
                 "Please, check your pending OS's" & vbCrLf & vbCrLf & _
                 "Detalhes:" & vbCrLf

    For Each emailAdress In emailInformation
        Set colLines = emailInformation(emailAdress)
        sBodyInfo = ""

        For Each line In colLines
            sBodyInfo = sBodyInfo & _
                    "Consultor:" & line.Client & vbCrLf & _
                    "Date:" & line.dDate & vbCrLf & _
                    "OS:" & line.OS & vbCrLf

        Next
        sBodyEnd = "Best Regards" & vbCrLf & _
                "Team"

        sBody = sBodyStart & sBodyInfo & sBodyEnd
        SendEmail emailAdress, "OS - PENDING", sBody
    Next


End Sub

Sub SendEmail(ByVal sTo As String _
              , ByVal sSubject As String _
                , ByVal sBody As String _
                  , Optional ByRef coll As Collection)


    #If Early Then
        Dim ol As Outlook.Application
        Dim outMail As Outlook.MailItem
        Set ol = New Outlook.Application
    #Else
        Dim ol As Object
        Dim outMail As Object
        Set ol = CreateObject("Outlook.Application")
    #End If

    Set outMail = ol.CreateItem(0)

    With outMail
        .To = sTo
        .Subject = sSubject
        .Body = sBody
        If Not (coll Is Nothing) Then
            Dim item As Variant
            For Each item In coll
                .Attachments.Add item
            Next
        End If

        .Display
        '.Send
    End With

    Set outMail = Nothing

End Sub