excel - 使用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

Answer 1

我已经写了好几次这样的代码-基本模板实际上在我的github上

代码：

Option Explicit


Sub LoopOverData()
Dim STbl As ListObject
Dim LastRow As Long
Dim WB As Workbook
Dim i As Long
Dim WS As Worksheet
Dim tblwsname As String


    Set WB = ThisWorkbook


    tblwsname = WB.Names("TblWSName").RefersToRange.Value2
    Set WS = WB.Sheets(tblwsname)
    Set STbl = WS.ListObjects("EmailDataTable")


    LastRow = STbl.ListRows.Count


    For i = 1 To LastRow
         WB.Names("IterationNumber").RefersToRange.Value2 = i
         Application.Calculate
         Call CreateEmail
    Next i



End Sub





Sub CreateEmail()
' This macro is for the pricing confirm e-mail
    Dim outApp As New Outlook.Application
    Dim OutMail As Object
    Dim Attchmnt As String
    Dim Signature As String
    Dim WB As Workbook
    Set WB = ThisWorkbook
   Attchmnt = WB.Names("Attachment").RefersToRange.Value2
   'We keep the file path for the attachment we're sending in Excel, for easy editing. Look in name manager to find it.

    Application.EnableEvents = False
     Application.ScreenUpdating = False

    ' We don't need the screen to flicker while the macro is running - it speeds things up.
    Set OutMail = outApp.CreateItem(0)
    'Signature = OutMail.Body
    On Error Resume Next
    With OutMail
    .To = WB.Names("to").RefersToRange.Value2
   .CC = WB.Names("cc").RefersToRange.Value2
   .BCC = WB.Names("bcc").RefersToRange.Value2
   .Subject = WB.Names("Subject").RefersToRange.Value2
   .Body = WB.Names("Body").RefersToRange.Value2
   .display
   End With

   If Attchmnt = "" Then
   Else
   OutMail.Attachments.Add Attchmnt
   End If

   'OutMail.send
   'Remove this comment to directly send. Not recommended.

   On Error GoTo 0
End Sub

设置：基本创建一个“示例电子邮件”，然后使用= index（Range，IndexNum）确定当前正在处理的项目。 IndexNum是一个返回到基本索引的命名范围，该代码将不断变化。

因此，随着索引中每个数字的移动，所有公式都会更新为需要编写的新电子邮件。然后，它调用电子邮件生成过程，并创建（但不发送）所需的电子邮件。这是给您一个机会，在发送之前先查看电子邮件。

您需要启用Microsoft Outlook 16.0对象库。

发送丢失的信息可能有一些规则-如果是这种情况，我建议您使用一些公式或幂查询来进行压缩