基于每行匹配的收件人，按行创build具有附件的Excel电子邮件

不知道如何最好地标题这一点，但我有一个工作表，我通过每一行循环，并为每一行创build一个电子邮件。 附件基于分部名称。 目前，它为每一行创build一个电子邮件，所以如果Name下的一个人有8个分部，他们将收到8个电子邮件，每个电子邮件有不同的附件。 这是令人讨厌的人，所以我想现在有循环（也许是嵌套？），如果如果find相同的名称，然后创build一个电子邮件为该名称，连同他们所有的司报告。

为了方便起见，我设定了名单，以便将所有名称都归为一组。 在这个例子中，我希望它创build一个电子邮件到名称示例Sample1，附件的小工具和门把手。 其余的，他们每个人都会收到他们平时的一封电子邮件。 我已经尝试了几个小时来使这个工作，但没有足够的VBA知识，使这项工作。 我可以用Excel自己做公式，基本上说，如果A2 = A3，那就这样做。 但是我需要帮助才能在VBA中发生这种情况。 请看图片。
更新 ：我已经更新了下面的代码，我使用了Vityata显示的因子分解方法。 它运行，但创build每个电子邮件的欺骗。

Option Explicit Public Sub TestMe() Dim name As String Dim division As String Dim mail As String Dim dict As Object Dim dictKey As Variant Dim rngCell As Range Set dict = CreateObject("Scripting.Dictionary") For Each rngCell In Range("b2:b4") If Not dict.Exists(rngCell.Value) Then dict.Add rngCell.Value, rngCell.Offset(0, -1) End If Next rngCell For Each dictKey In dict.keys SendMail dictKey, dict(dictKey) Next dictKey End Sub Public Sub SendMail(ByVal address As String, ByVal person As String) Dim OutApp As Object Dim OutMail As Object Dim cell As Range Dim strdir As String Dim strFilename As String Dim sigString As String Dim strBody As String Dim strName As String Dim strName1 As String Dim strDept As String Dim strName2 As String Application.ScreenUpdating = False Set OutApp = CreateObject("Outlook.Application") sigString = Environ("appdata") & _ "\Microsoft\Signatures\Test.htm" If Dir(sigString) <> "" Then signature = GetBoiler(sigString) Else signature = "" End If strdir = "z:\" strBody = "<Font Face=calibri>Please review the attached report for your department." For Each address In Columns("B").Cells.SpecialCells(xlCellTypeConstants) If cell.Value Like "?*@?*.?*" And _ LCase(Cells(cell.Row, "C").Value) = "yes" Then Set OutMail = OutApp.CreateItem(0) With OutMail strName = Cells(cell.Row, "a").Value strName1 = Cells(cell.Row, "d").Value strName2 = Left(strName, InStr(strName & " ", " ") - 1) strFilename = Dir("z:\*" & strName1 & "*") .To = cell.Value .Subject = "Monthly Budget Deficit Report for " & strName1 .HTMLBody = "<Font Face=calibri>" & "Dear " & address & ",<br><br>" .Attachments.Add strdir & strFilename .Display 'Or use Send End With Set OutMail = Nothing End If Next cell End Sub Function GetBoiler(ByVal sFile As String) As String Dim fso As Object Dim ts As Object Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2) GetBoiler = ts.ReadAll ts.Close End Function 

Answer 1

像这样的问题可以总结如下： 如何避免在VBA中的重复值 ，只要你不想发送两次相同的电子邮件到相同的地址。

因此，想象下面的数据：

您不想将电子邮件两次发送给Test先生和Test2先生。 有什么select？ 尝试build立一个字典，作为唯一的邮件列的关键。 然后重构你的代码，只将代码发送给“制作”到字典中的人。 你需要重构你的代码，最后得到这样的结果：

 Option Explicit Public Sub TestMe() Dim name As String Dim division As String Dim mail As String Dim dict As Object Dim dictKey As Variant Dim rngCell As Range Set dict = CreateObject("Scripting.Dictionary") For Each rngCell In Range("C2:C6") If Not dict.exists(rngCell.Value) Then dict.Add rngCell.Value, rngCell.Offset(0, -1) End If Next rngCell For Each dictKey In dict.keys SendMail dictKey, dict(dictKey) Next dictKey End Sub Public Sub SendMail(ByVal address As String, ByVal person As String) Debug.Print "Mr./Mrs. " & person & ", here is your email -> " & address End Sub 

这是你得到的：

 Mr./Mrs. Test, here is your email -> test@tt Mr./Mrs. Test2, here is your email -> test2@tt Mr./Mrs. Test3, here is your email -> test3@tt 

重构的思想是将“从Excel中读取”逻辑从“发送电子邮件”逻辑中分离出来。 在“从Excel中读取”逻辑中，您只能阅读那些独特的部分，在“发送电子邮件”中，您将发送邮件给任何已通过阅读逻辑的人。