VBA code to email multiple recipients from a list

[willow1985]

Hello,

I need some help modifying this code.
for the TO portion, I need it to list each email until the end of the data.
for the body portion I need it to copy data from B1 to end of column L based on the last row of data in column B

This pic is just an example (the info goes from column B to L)

Thanks in advance for the help with this modification

 Dim OutlookApp As Object, MItem As Object
  Set OutlookApp = CreateObject("Outlook.Application")
  Set MItem = OutlookApp.CreateItem(0)
  With MItem
    .to = 'go to B2 on list and continue till no more data'
    .Subject = Sheets("Automatic Emails").Range("Q1")
    .Body = Sheets("Automatic Emails").Range("Q2")& vbCrLf & vbCrLf &
'Copy data from B1 to column L (last row of data according to column B) AND
& vbCrLf & vbCrLf & vbCrLf & "[This is an Automated Message - Do not reply]" & vbCrLf & "Quality Department"
    .Display
    .Send
  End With

 

[Domenic]

The following code uses the HTMLBody property of the MailtItem object, instead of the Body property. For each row, it builds an html string, and then assigns it to the HTMLBody. For example, the html string for a row would look something like this...

<p>Email body message</p>
<table>
<tr>
<td>Date</td><td>text</td><td>text</td><td>text</td><td>text</td><td>text</td><td>text</td><td>text</td><td>text</td><td>text</td><td>text</td>
</tr>
</table>
<p>[This is an Automated Message - Do not reply]<br>Quality Department</p>

Here's the code...

Option Explicit

Sub CreateEmails()

    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = Worksheets("Automatic Emails")
    
    Dim lastRow As Long
    With sourceWorksheet
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With

    Dim OutlookApp As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    
    Dim rowIndex As Long
    For rowIndex = 2 To lastRow 'start at the second row
        Dim MItem As Object
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = sourceWorksheet.Cells(rowIndex, "A").Value
            .Subject = sourceWorksheet.Range("Q1")
            'build html string for body of email
            Dim htmlBody As String
            htmlBody = "<p>" & sourceWorksheet.Range("Q2").Value & "</p>" & vbCrLf
            htmlBody = htmlBody & "<table>" & vbCrLf
            htmlBody = htmlBody & "<tr>" & vbCrLf
            With sourceWorksheet.Range("B" & rowIndex & ":L" & rowIndex)
                Dim currentCell As Range
                For Each currentCell In .Cells
                    htmlBody = htmlBody & "<td>" & currentCell & "</td>"
                Next currentCell
            End With
            htmlBody = htmlBody & vbCrLf & "</tr>" & vbCrLf
            htmlBody = htmlBody & "</table>" & vbCrLf
            htmlBody = htmlBody & "<p>[This is an Automated Message - Do not reply]<br>"
            htmlBody = htmlBody & "Quality Department</p>"
            .htmlBody = htmlBody
        .display
        '.Send
        End With
    Next rowIndex
 
End Sub

Hope this helps!

 

[willow1985]

The above code did not copy the headers when it was copying the data from Range B1:L

'Copy data from B1 to column L (last row of data according to column B).

It seemed to copy from B2 to the end of the data in L

 

[willow1985]

It is also not copying the borders/formatting. Is there any way to do this?
Would this work?:

Sheets("Automatic Emails").Range(Range("B1"), Range("B1:L").End(xlDown)).Copy
OutlookApp.ActiveInspector.WordEditor.Application.Selection.Paste

Thank you

 

[DanteAmor]

Try this way to set the range, run the macro "sendmail"

Sub sendmail()
  Dim OutlookApp As Object, MItem As Object
  Dim i As Long, sh As Worksheet, rng As Range, lr As Long
  
  Set sh = Sheets("Automatic Emails")
  lr = sh.Range("B" & Rows.Count).End(xlUp).Row
  Set rng = sh.Range("B1:L" & lr)
  For i = 2 To lr
    Set OutlookApp = CreateObject("Outlook.Application")
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
      .To = sh.Range("B" & i).Value
      .Subject = sh.Range("Q1").Value
      .HTMLBody = sh.Range("Q2").Value & RangetoHTML(rng) & _
        "<br>[This is an Automated Message - Do not reply]<br>" & _
        "Quality Department"
      .Display
      .Send
    End With
  Next
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[willow1985]

I am getting an error with DanteAmor's code, it has an end sub in the middle?.

I had to change the email list reference column from A to L and move the data over (B to K )but I still have problems both codes when modified.

Here is the data and here is how the end result e-mail should look:

Data:

Email:

Here is my full code (minus the email portion):

Sub Flag()
'
' Flag Macro
'

'
Msg = "E-mails will be automatically generated and sent for any Audits Scheduled that have reached their Flag date." & vbCrLf & "" & vbCrLf & "Do you wish to proceed?"

    Ans = MsgBox(Msg, vbYesNo)

    Select Case Ans

        Case vbYes
Sheets("Automatic Emails").Select
    Range("A2:K30").Select
    Selection.ClearContents
    Range("A1").Select
Sheets("Aerospace Schedule").Select
For Each lo In ActiveSheet.ListObjects
    lo.AutoFilter.ShowAllData
      Next lo
    Cells.Select
    ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=12, Criteria1:= _
        "Y"
    LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A2:K" & LastRowColumnA).Select
    Selection.Copy
    Sheets("Automatic Emails").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
Range("L2").Select
LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row
    Range("L2:L" & LastRowColumnA).Formula = "=INDEX(C[2],MATCH(RC[-8],C[1],FALSE))"
    Columns("G:G").Select
    Selection.NumberFormat = "m/d/yyyy"
        With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
Columns("J:J").Select
    Selection.NumberFormat = "m/d/yyyy"
        With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("K:K").Select
    Selection.NumberFormat = "m/d/yyyy"
        With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
  
Range("B1").Select


 'EMAIL CODE


Msg = "Reminder e-mails sent"

  Case vbNo
        GoTo Quit:
    End Select

Quit:
End Sub

 

[DanteAmor]

Replace all your code with the following.
Run the "Flag" macro

Sub Flag()
'
' Flag Macro
'

'
msg = "E-mails will be automatically generated and sent for any Audits Scheduled that have reached their Flag date." & vbCrLf & "" & vbCrLf & "Do you wish to proceed?"

    ans = MsgBox(msg, vbYesNo)

    Select Case ans

        Case vbYes
Sheets("Automatic Emails").Select
    Range("A2:K30").Select
    Selection.ClearContents
    Range("A1").Select
Sheets("Aerospace Schedule").Select
For Each lo In ActiveSheet.ListObjects
    lo.AutoFilter.ShowAllData
      Next lo
    Cells.Select
    ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=12, Criteria1:= _
        "Y"
    LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A2:K" & LastRowColumnA).Select
    Selection.Copy
    Sheets("Automatic Emails").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
Range("L2").Select
LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row
    Range("L2:L" & LastRowColumnA).Formula = "=INDEX(C[2],MATCH(RC[-8],C[1],FALSE))"
    Columns("G:G").Select
    Selection.NumberFormat = "m/d/yyyy"
        With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
Columns("J:J").Select
    Selection.NumberFormat = "m/d/yyyy"
        With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("K:K").Select
    Selection.NumberFormat = "m/d/yyyy"
        With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
Range("B1").Select


 'EMAIL CODE
  Call sendmail

msg = "Reminder e-mails sent"

  Case vbNo
        GoTo Quit:
    End Select

Quit:
End Sub

Sub sendmail()
  Dim OutlookApp As Object, MItem As Object
  Dim i As Long, sh As Worksheet, rng As Range, lr As Long
 
  Set sh = Sheets("Automatic Emails")
  lr = sh.Range("B" & Rows.Count).End(xlUp).Row
  Set rng = sh.Range("B1:K" & lr)
  For i = 2 To lr
    Set OutlookApp = CreateObject("Outlook.Application")
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
      .To = sh.Range("L" & i).Value
      .Subject = sh.Range("Q1").Value
      .HTMLBody = sh.Range("Q2").Value & RangetoHTML(rng) & _
        "<br>[This is an Automated Message - Do not reply]<br>" & _
        "Quality Department"
      .Display
      .Send
    End With
  Next
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[willow1985]

Works perfect but the only thing the code did not execute was:

msg = "Reminder e-mails sent"

When the code was done running. and for some reason row 2 had red font in the email but not in the spreadsheet??

Just these last 2 hiccups and should be good. Thanks a million DanteAmor!

 

[willow1985]

Red Font. Not sure why as it is black on the spreadsheet.....

 

[DanteAmor]

Change this
msg = "Reminder e-mails sent"

By this
msgbox "Reminder e-mails sent"


Try, change this:

    Range("A2:K30").Select
    Selection.Clear

By this:

    Range("A2:K30").Select
    Selection.Clear