VBA Generate email with multiple data in body.

[RedOctoberKnight]

Good Evening All,

I currently have a workbook that I use to send out overdue training assignments. I have a daily training report emailed to me. The overdue training assignments are in column A with the person's last name in B, first name in C, and their email address is in column D. I currently copy and paste columns B-D into my "email generator" that basically removes all the duplicate email addresses and then sends a generic " you have overdue training email"

What I would like it to do is send a single email to each individual with a list of the overdue training subjects in the body instead of having to send an email to each individual for each topic.

The following is the code I currently use in my email generator.

Sub ComplyEmail()

Dim edress As String, Subject As String, name As String

Dim outlookapp As Object, outlookmailitem As Object

Dim X As Integer, erow As Integer

Dim emailBase As String

emailBase = "@wnco.com"


Range("A1:C1000").RemoveDuplicates Columns:=1, Header:=xlYes


erow = Sheet1.Cells(Sheet1.Rows.Count, "C").End(xlUp).Row


For X = 2 To erow

If Sheet1.Cells(X, 3).Value <> "" Then

Sheet1.Cells(X, 4).Value = Sheet1.Cells(X, 3).Value & emailBase

Else

Sheet1.Cells(X, 4).Value = ""

End If

Next X


Set outlookapp = CreateObject("Outlook.Application")


For X = 2 To erow

edress = Sheet1.Cells(X, 4)

name = Sheet1.Cells(X, 5)

If edress <> "" And name <> "" Then



Set outlookmailitem = outlookapp.CreateItem(0)

Subject = "Attention - You have overdue Training"


outlookmailitem.Body = "Good Morning " & name & "," & vbCrLf & vbCrLf & _

"Removed for security reasons"





outlookmailitem.To = edress

outlookmailitem.Subject = Subject

outlookmailitem.Display


End If

Next X





Set outlookapp = Nothing


End Sub

Any help would be much appreciated.

Thanks,

 

[LongToast]

I think you'll need "sort" and "filter" not "remove duplicate", sort so your data Will represented as group with same person with different assignments, and filter to get list of that person assignments, just a thought.

 

[Logit]

Option Explicit


Sub srtMe()
Dim lastrow As Long

lastrow = Cells(Rows.Count, 4)
Range("D2:D10").EntireRow.Sort key1:=Range("D2:D10"), order1:=xlAscending, Header:=xlNo     '<--- Edit number of rows here
    
CreateSheets
    
End Sub

Sub CreateSheets()

    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet

    Set RngBeg = Worksheets("Sheet1").Range("D2")
    Set RngEnd = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)

Application.ScreenUpdating = False

        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub

        For Each Cell In Worksheets("Sheet1").Range(RngBeg, RngEnd)
            On Error Resume Next
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Cell.Value)

                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                  
                    Wks.Name = Cell.Value
                End If
            On Error GoTo 0
            
        Next Cell
        
Application.ScreenUpdating = True

MakeHeaders

End Sub

Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Sheet1"
Application.ScreenUpdating = False
For dst = 2 To Sheets.Count
    If Sheets(dst).Name <> srcSheet Then   'And Sheets(dst).Name <> "Sheet1" Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    Range("A1").EntireRow.Font.Bold = True
    Columns("A:D").EntireColumn.AutoFit
    Sheets(dst).Range("A1").Select
    End If
Next
Application.ScreenUpdating = True

CopyData

End Sub

Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim lastrow As Long
On Error Resume Next
lastrow = Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
Dim ans As String
    
    For i = 2 To lastrow
    ans = Sheets("Sheet1").Cells(i, 4).Value
        Sheets("Sheet1").Rows(i).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "A").End(xlUp).Row + 1)
        Sheets(ans).Range("A1").EntireRow.Font.Bold = True
        Sheets(ans).Columns("A:D").EntireColumn.AutoFit
    Next
Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
Application.ScreenUpdating = True

Call Outlook_Mail_Every_Worksheet_Body

End Sub

Sub Outlook_Mail_Every_Worksheet_Body()
Dim ws As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim vInspector, GetInspector, wEditor As Variant

Application.ScreenUpdating = False

For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Sheet1" Then
            If ws.Range("D2").Value Like "?*@?*.?*" Then
                ws.Range("A1:D20").Copy
            Set OutApp = CreateObject("Outlook.Application")
            Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = ws.Range("D2").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = "Outstanding Training Requirements As Of : " & VBA.Format(Now, " dd-mm-yyyy")
                    .Body = ""
                    .Display
                    ws.Range("A1:D20").Copy
                    Set vInspector = OutMail.GetInspector
                    Set wEditor = vInspector.WordEditor
                
                    wEditor.Application.Selection.Start = Len(.Body)
                    wEditor.Application.Selection.End = wEditor.Application.Selection.Start
                
                    wEditor.Application.Selection.Paste
                
                .Display
                End With
            End If
        End If
Next ws

Application.ScreenUpdating = True


End Sub

Download sample workbook : Internxt Drive – Private & Secure Cloud Storage