使用VBA从Excel构建电子邮件，当地址重复时合并电子邮件正文

Question

首先，我对VBA非常陌生。仍在学习，所以我可能会犯一些明显的错误。

我正在尝试使用Excel电子表格构建电子邮件，该电子表格是我从中提取信息以填充电子邮件的“收件人”，“主题”和“正文”的内容。这些将用于销售人员为他们的客户查看信息。我需要每封电子邮件都基于客户，并发送给相应的销售代表。一些客户拥有多条信息，而其他客户则拥有多个信息，而某些销售人员则拥有重叠的客户。

我发现并一直在尝试编辑的代码（据我所知）是根据电子邮件地址构建电子邮件。因此，我最后收到一封电子邮件，在“收件人”行中有一个销售人员，并且该正文具有专门针对该销售人员的所有客户。同时，主题行仅吸引电子邮件打算显示的一位客户。

在这方面的任何帮助将是天赐之物。我试图将4-6小时的工作量减少到1小时以下。

每当我尝试更改代码以使其基于客户而不是电子邮件地址时，我要么最终破坏代码，要么不构建电子邮件，而是以某种方式将过滤器应用于电子表格，以过滤出与在更改之前正在查看电子邮件。

我觉得可能需要更多的信息，因为我发现这比看起来要复杂得多，但这可能是我在思考问题。我试图将这篇文章限制为仅提供相关信息，但是如果我需要提供更多信息，我当然会。我已经为此动了好几个星期。

我尝试了各种If And / Then语句来尝试使代码在“客户”列而不是“电子邮件”列中显示，但是我找不到任何有效的组合。我在下面发布的代码已在一定程度上设法使我工作。由于我已经尝试了许多变体，所以我不知道要包括的最佳错误是什么。因此希望这至少不会太混乱。

*编辑：代码要求在A列中有一列名称，据我所知，这是“为此名称使用B列中的地址创建电子邮件”的条件。但是，这似乎是在使用B列中的地址作为条件来创建电子邮件。因此，A中任何与B中的地址匹配的客户行都被投到同一封电子邮件中。我有点需要反过来。列A中每位客户的一封电子邮件发送到列B中列出的电子邮件地址。

Edit2：源信息看起来像这样：

+----------------+---------------------+---------+--------------+
|     Customer   |       Email         | Subj Ln |  Email Body  |
+----------------+---------------------+---------+--------------+
| Customer 1     | sales1@address.com  | info    |     info     |
| Customer 2     | sales2@address.com  | info    |     info     |
| Customer 2     | sales2@address.com  | info    |     info     |
| Customer 2     | sales2@address.com  | info    |     info     |
| Customer 3     | sales2@address.com  | info    |     info     |
| Customer 4     | sales3@address.com  | info    |     info     |
| Customer 4     | sales3@address.com  | info    |     info     |
| Customer 5     | sales1@address.com  | info    |     info     |
| Customer 6     | sales4@address.com  | info    |     info     |
+----------------+---------------------+---------+--------------+

因此，代码应查看“客户”列（A列），并查找唯一的实例，然后在“电子邮件”列（B列）中生成具有适当电子邮件地址的电子邮件。每个电子邮件应该是单独的一封电子邮件，并且当电子邮件地址对于客户是唯一的时，它将这样做。因此，在上面的示例中，客户6收到一封单独的电子邮件给sales4。电子邮件会生成适当的主题行和电子邮件正文。但是，客户1将生成带有适当的主题和电子邮件正文（针对客户1）的电子邮件，并且还将具有适当的sales1电子邮件地址。但是由于sales1也有客户5，因此客户1的电子邮件中包含客户5的电子邮件正文信息。当我需要客户5作为单独的电子邮件时。

Edit3：我在下面添加了以下段落作为注释，因为我不确定哪一种是获得可见性的最佳方法。

我一直在玩这些代码，以为我可能发现了以前不完全了解的内容。我不确定是否仍会这样做，但我认为我有更好的理解。-看起来代码正在创建一个过滤器，用于构建电子邮件的正文。它会过滤B列（电子邮件）中的唯一值，并根据此值创建电子邮件。我认为，如果我可以更改该过滤器代码以过滤A列并使用B列构建电子邮件，那么我想我会得到想要的东西。我只是不知道如何使这项工作。

我希望我清楚。这让我感到非常困惑和不知所措，但我希望这是有道理的。另外，我希望我的格式正确。

Sub Send_Row_Or_Rows_2()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet

'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:AY" & Ash.Rows.Count)
FieldNum = 2    'Filter column = B because the filter range start in 
column A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=Cws.Range("A1"), _
        CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
    For Rnum = 2 To Rcount

        'Filter the FilterRange on the FieldNum column
        FilterRange.AutoFilter Field:=FieldNum, _
                               Criteria1:=Cws.Cells(Rnum, 1).Value

        'If the unique value is a mail addres create a mail
        If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next
            With OutMail
                .To = Cws.Cells(Rnum, 1).Value
                .Subject = Ash.Cells(Rnum, 3) & " Bond Review " & Date
                .HTMLBody = RangetoHTML(rng)
                .Display  'Or use Send
            End With
            On Error GoTo 0

            Set OutMail = Nothing
        End If

        'Close AutoFilter
        Ash.AutoFilterMode = False

    Next Rnum
End If

cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

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

Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & 
".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
     SourceType:=xlSourceRange, _
     Filename:=TempFile, _
     Sheet:=TempWB.Sheets(1).Name, _
     Source:=TempWB.Sheets(1).UsedRange.Address, _
     HtmlType:=xlHtmlStatic)
    .Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                      "align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Public Function EOMonth(dInput As Date)

LastDayOfMonth = DateSerial(Year(dInput()), Month(dInput() + 1), -1)

End Function