使用 VBA 和 Outlook 向每位经理发送一份报告

Question

我有一个列表，其中包含：
- 客户 - 经理电子邮件
- 总经理邮箱

我正在尝试使用 VBA 和 Outlook 发送电子邮件，每次循环找到一个经理（我正在检查电子邮件地址）时，它都会发送为该经理列出的每个客户。

如果分行没有列出经理的电子邮件地址，则该电子邮件应发送给主管（例如，分行 1236 会收到一封电子邮件，发送给主管，其中有几个客户）。

电子邮件正文将包含预先格式化的文本，然后是工作表列表和客户列表。

我遇到了一些麻烦：

a) 列出从工作表到邮件正文的分行客户
b) 在第一封电子邮件之后从下一个经理跳转，而不是每次循环找到同一个经理时都为同一个经理重复电子邮件
c) 记录发送到 J 列的邮件

这是一张包含一些报告的表格： https://drive.google.com/file/d/1Qo-DceY8exXLVR7uts3YU6cKT_OOGJ21/view?usp=sharing

我的循环有点工作，但我相信我需要一些其他方法来实现这一点。

Private Sub CommandButton2_Click() 'envia o email com registro de log

    Dim OutlookApp As Object
    Dim emailformatado As Object
    Dim cell As Range
    Dim destinatario As String
    Dim comcopia As String
    Dim assunto As String
   'Dim body_ As String
    Dim anexo As String
    Dim corpodoemail As String
   'Dim publicoalvo As String

    Set OutlookApp = CreateObject("Outlook.Application")

   'Loop para verificar se o e-mail irá para o gerente da carteira ou para o gerente geral
    For Each cell In Sheets("publico").Range("H2:H2000").Cells

        If cell.Row <> 0 Then
            If cell.Value <> "" Then                   'Verifica se carteira possui gerente.
                destinatario = cell.Value              'Email do gerente da carteira.
            Else
                destinatario = cell.Offset(0, 1).Value 'Email do Gerente Geral.
            End If
            assunto = Sheets("CAPA").Range("F8").Value 'Assunto do e-mail, conforme CAPA.
           'publicoalvo = cell.Offset(0, 2).Value
           'body_ = Sheets("CAPA").Range("D2").Value
            corpodoemail = Sheets("CAPA").Range("F11").Value & "<br><br>" & _
            Sheets("CAPA").Range("F13").Value & "<br><br>" ' & _
            Sheets("CAPA").Range("F7").Value & "<br><br><br>"
           'comcopia = cell.Offset(0, 3).Value         'Caso necessário, adaptar para enviar email com cópia.
           'anexo = cell.Offset(0, 4).Value            'Caso necessário, adaptar para incluir anexo ao email.

           'Montagem e envio dos emails.
            Set emailformatado = OutlookApp.CreateItem(0)
            With emailformatado
                .To = destinatario
               '.CC = comcopia
                .Subject = assunto
                .HTMLBody = corpodoemail '& publicoalvo
                '.Attachments.Add anexo
                '.Display
            End With
            emailformatado.Send
            Sheets("publico").Range("J2").Value = "enviado"
        End If
    Next

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Answer 1

拥有一个包含客户端集合的管理器类。拥有一组管理器实例。

Manager Class
'@Folder("VBAProject")
Option Explicit

Private Type TManager
    ManagerEmail As String
    Clients As Collection
End Type
Private this As TManager


Private Sub Class_Initialize()
    Set this.Clients = New Collection
End Sub

Private Sub Class_Terminate()
    Set this.Clients = Nothing
End Sub
Public Property Get ManagerEmail() As String
    ManagerEmail = this.ManagerEmail
End Property
Public Property Let ManagerEmail(ByVal value As String)
    this.ManagerEmail = value
End Property
Public Property Get Clients() As Collection
    Set Clients = this.Clients
End Property

Client Class
'@Folder("VBAProject")
Option Explicit

Private Type TClient
    ClientID As String
End Type
Private this As TClient

Public Property Get ClientID() As String
    ClientID = this.ClientID
End Property
Public Property Let ClientID(ByVal value As String)
    this.ClientID = value
End Property

Standard Module
Option Explicit
Dim Managers As Collection
Sub PopulateManagers()
    Set Managers = New Collection
    Dim currWS As Worksheet
    Set currWS = ThisWorkbook.Worksheets("publico")
    With currWS
        Dim loopRange As Range
        Set loopRange = .Range(.Cells(2, 8), .Cells(.UsedRange.Rows.Count, 8)) 'H2 to the last used row; assuming it's the column for manager emails
    End With
    Dim currCell As Range
    For Each currCell In loopRange
        If currCell.value = vbNullString Then 'no manager; try for a head manager
            If currCell.Offset(0, 1).value = vbNullString Then 'no managers at all
                Dim currManagerEmail As String
                currManagerEmail = "NoManagerFound"
            Else
                currManagerEmail = currCell.Offset(0, 1).Text
            End If
        Else
            currManagerEmail = currCell.Text
        End If
        Dim currManager As Manager
        Set currManager = Nothing
        On Error Resume Next
            Set currManager = Managers(currManagerEmail)
        On Error GoTo 0
        If currManager Is Nothing Then
            Set currManager = New Manager
            currManager.ManagerEmail = currManagerEmail
            Managers.Add currManager, Key:=currManager.ManagerEmail
        End If
        Dim currClient As Client
        Set currClient = New Client
        currClient.ClientID = currWS.Cells(currCell.Row, 1).Text 'assumes client ID is in column 1
        currManager.Clients.Add currClient, Key:=currClient.ClientID
    Next
End Sub

一旦您拥有经理的集合，只需将其循环以创建您的经理专用电子邮件。

由于我使用 Usedrange.Rows.Count 设置循环范围，它应该可以正常工作，无需额外检查。但是，由于我无法确定您的实际数据，因此您可能需要它。我没有行号，所以我不知道第 51 行指的是什么。循环管理器：

Sub LoopManagers()
    Dim currManager As Manager
    For Each currManager In Managers
        Debug.Print currManager.ManagerEmail
        Dim currClient As Client
        For Each currClient In currManager.Clients
            Debug.Print currClient.ClientID
        Next
    Next
End Sub

您需要调整我提供的内容来创建您的电子邮件。在...上下功夫。如果您需要更多帮助，请发布您的尝试并描述您遇到的问题。