Question

我有一个宏，可以为每个＆＃34;供应商＆＃34;我需要发送＆＃34; CC＆＃34;给＃34;供应商的相应主管＆＃34;现在

原始帖子位于Consolidate Excel Information in one e-mail for each user

链接中

Vendor              Consultor   CLIENT  Date        OS      Status Supervisor
-----------------------------------------------------------------------------
test@test.com       Andrew      NAME 1  25/12/2017  123456  Pend   John@test
test@test.com       Andrew      NAME 2  31/12/2017  789123  Pend   John@test
test134@test.com    Joseph      NAME 3  10/12/2017  654321  Pend   Mike@test

Answer 1

我的假设是，一个供应商拥有一个主管，即1：1的关系。

将以下属性添加到类cVendorline

    ' New Property for the mail address of the supervisor
Public Property Get MailSupervisor() As String
    MailSupervisor = mMailSupervisor
End Property

Public Property Let MailSupervisor(ByVal sNewValue As String)
    mMailSupervisor = sNewValue
End Property

所以cVendorline类的完整代码是

Option Explicit

Private mClient As String
Private mDate As Date
Private mOS As String    
Private mMailSupervisor 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
' New Property for the mail address of the supervisor
Public Property Get MailSupervisor() As String
    MailSupervisor = mMailSupervisor
End Property

Public Property Let MailSupervisor(ByVal sNewValue As String)
    mMailSupervisor = sNewValue
End Property

使用

从原始帖子中复制模块中的代码

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)
' added CONSTs for the columns (just to make it "nicer")
Const COL_MAILVENDOR = 1
Const COL_CLIENT = 3
Const COL_DATE = 4
Const COL_OS = 5
Const COL_MAILSUPERVISOR = 7

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, COL_MAILVENDOR)

        Set vendorLine = New cVendorline
        With vendorLine
            .Client = sngRow.Cells(1, COL_CLIENT)
            .dDate = sngRow.Cells(1, COL_DATE)
            .OS = sngRow.Cells(1, COL_OS)
            ' new column for supoervisor
            .MailSupervisor = sngRow.Cells(1, COL_MAILSUPERVISOR)
        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 sCC 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
                    ' just get the supervisor's mail from the last entry
                    ' maybe a little bit sloppy to do it like that
                    sCC = line.MailSupervisor
        Next
        sBodyEnd = "Best Regards" & vbCrLf & _
                "Team"

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

End Sub

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

    #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
        .cc = sCC
        .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

在每个列的一封电子邮件中合并Excel信息

1 个答案: