通过范围VBA向人们发送电子邮件

Question

我有以下数据集

我有以下代码将电子邮件发送到每一行。如何使其对行进行分组，并将它们全部发送为1张电子邮件，如图所示

这是我要创建的电子邮件的示例

此刻，代码逐步遍历每一行并以此为基础进行构建并通过电子邮件发送。我希望它检查A列中的代码，并找到其他所有具有相同代码的列，并使用其所有列中的信息构建一封电子邮件

pandoc Example1.md -o Example1.pdf

Answer 1

我知道您现在要做什么。您应该将循环从在每一列上运行改为改为逐行执行。类似于... 如果行上方没有成员，请收集该行列中的所有适当成员，然后循环遍历其余行，测试它们是否匹配，然后将其附加到电子邮件中。

此刻，我很懒惰将其写出来，但这是一个自定义公式，可以帮助您仅测试相应行中的成员是否位于上方。

Sub SendIntransitEmail()

    Dim Mail_Object, OutApp As Variant
    Dim eRng1, eRng2, eRng3, rng1, rng2, rng3, rng4, cl As Range
    Dim sTo, sCC, sLoc, sFile1, sFile2, sHeader, sBody As String

    Set rng4 = ThisWorkbook.Worksheets("sheet1").Range("B4")

    Dim intNum As Integer
        intNum = ThisWorkbook.Worksheets("sheet1").Range("B1")

    Set Mail_Object = CreateObject("Outlook.Application")


    For i = 5 To intNum
    On Error Resume Next 'I wouldn't use this...

        'test if first instance of plant
        If New_Plant_Test(ThisWorkbook.Worksheets("sheet1").Cells(i, 1)) = True Then
            'run a loop from this row all the way down to populate the respective emails,
            'example:
                For Each rcell In Range(ThisWorkbook.Worksheets("sheet1").Cells(i, 1), ThisWorkbook.Worksheets("sheet1").Cells(intNum, 1)).Cells
                        'apply respective values to variables in that row.
                        'this should probably be a separate private macro.
                Next rcell

            'send email and clear variables and clear variables

        Else
            'skips as plant already existed
        End If

    Next i 'continue loop by each row

    End Sub

Private Function New_Plant_Test(rng As Range) As Boolean

Dim tRow As Long, ws As Worksheet
tRow = rng.Row
Set ws = Sheets(rng.Parent.Name)

On Error GoTo NewMember
    tRow = Application.WorksheetFunction.Match(ws.Cells(tRow, 1), Range(ws.Cells(1, 1), ws.Cells(tRow - 1, 1)), False)
On Error GoTo 0

Exit Function
NewMember:
    New_Plant_Test = True

End Function