How to Send Group emails

Yolandi

As Variatus suggests, please change your question title to refer to Group emails (rather than Bulk).

Further to your code in the discussion, I've modified the workbook you sent last week to:

   1) Have a sheet called "Send Rep email" wth a button to click

   2) Include a sheet "Reps" which is the Contact info but with duplicates removed.

In the macro behind the button in 1 above, I define RepRows as a range then use this basic structure:

For Each rep In Worksheets("Reps").Range("A2:A10")

<< code to match data with rep>>
<< code to send emails>>

Next Rep

In my case in the < <code to match data with rep>>, there's your For Next loop with an If Then decision- this just matches the column A value with the rep's name (from the For Each) and extends the range RepRows if it matches. Once the For Next loop is run, all rows in Report for a given Rep will be in the Range.

In the << code to send emails>>, I've just changed the HTML body to includes HTML conversion of that RepRows range.

You will get a single email per rep with ALL the rows in Report which match the rep's names. I leave you to modify the If decision to limilt that (to your 999 codes say) and tidy unused bits of the code and in the Send Rep emails sheet.

Hope this works. Please Select my answer if it does. Good luck

Private Sub Cb_GrpEmails_Click()

Dim OutApp As Object
Dim OutMail As Object
Dim i, lr As Long
Dim Path, Signature As String
Dim Rng As Range
Dim rng1 As Range
Dim RepRows As Range

On Error Resume Next

Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

For Each rep In Worksheets("Reps").Range("A2:A10")
MsgBox "Preparing email for " & rep & ": " & rep.Offset(0, 3).Value ' check

    'lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row

    Set RepRows = Sheet1.Range("A1:Y1")
    For i = 2 To Sheet1.Cells(Rows.Count, "K").End(xlUp).Row
    If Trim(Sheet1.Cells(i, 1).Value) = rep.Value Then
       'If Sheet1.Cells(i, "W").Value = "999" Then
        'Set rng1 = Range("A1:Y1")
        Set RepRows = Union(RepRows, Sheet1.Range("A" & i & ":Y" & i))
     End If
    Next i

    With OutMail
    .Display
    End With
    Signature = OutMail.HTMLBody


    With OutMail
    .To = rep.Offset(0, 3).Value
    .CC = "juan@effectivesales.co.za"
    .Subject = "SOH with No Sales"
    .HTMLBody = "Good day, " & Chr(11) & Chr(11) & "Please advise on below 999 lines (SOH No Sales):" & Chr(11) & Chr(11) & RangetoHTML(RepRows) 'RangetoHTML(rng1) & RangetoHTML(Rng) & Chr(11) & Chr(11) & Signature
    .Display
    End With

Next rep

Set OutMail = Nothing
Set OutApp = Nothing



With Application
.CutCopyMode = False
 .ScreenUpdating = True
End With
End Sub