Question

不确定如何最好地标题，但我有一张表，我循环每行并为每一行创建一个电子邮件。附件基于部门名称。目前，它会为每一行创建一封电子邮件，因此，如果名称下的一个人，即8个部门，他们将收到8封电子邮件，每封电子邮件都有不同的附件。这是烦人的，所以我想现在循环（可能是嵌套？），如果找到相同的名称，然后为该名称创建一个电子邮件，并附上所有的分部报告。

为了方便起见，我设置了列表，以便将所有重写名称全部组合在一起。在这个例子中，我希望它为Name Sample Sample1创建一个电子邮件，其中包含Widgets和Doorknobs的附件。然后，对于其余的，他们每个人都会得到他们通常的一封电子邮我已经尝试了几个小时才能使这个工作，但只是没有足够的VBA知识来使这项工作。我可以在Excel中使用公式来完成它，基本上说如果A2 = A3，那么就这样做。但我需要帮助才能在VBA中实现这一点。请看图像更新：我已经使用Vityata显示的分解方法更新了下面的代码。它运行，但每个电子邮件都会产生欺骗。

Sheet Example

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先生发送电子邮件。有什么选择？尝试构建一个字典，作为唯一邮件列的关键字。然后重构你的代码，只将代码发送给那些“使它成为”字典的人。你需要重构你的代码，最后你得到这样的东西：

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@t.t
Mr./Mrs. Test2, here is your email -> test2@t.t
Mr./Mrs. Test3, here is your email -> test3@t.t

重构的想法是，您将“从Excel读取”逻辑与“发送电子邮件”逻辑分开。在“从Excel读取”逻辑中，您将只读取那些独特的部分，并且在“发送电子邮件”中您将向已通过阅读逻辑的任何人发送邮件。

根据每行中匹配的收件人，使用附件行从Excel创建电子邮件

1 个答案: