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

 

[willow1985]

Perfect! Thank you so much!

This code is quite amazing I must say. I didn't know you could copy data into a temporary workbook as a html file... with this knowledge there is a lot of opportunities....

I don't understand the function code very much so I will definitely have to read up on this more. Thank you very much DanteAmor

 

[DanteAmor]

I am glad to know that this already works for you. Thanks for the feedback

 

[willow1985]

Sorry, 1 more question relating to this:

I noticed it was sending individual e-mails, is there a way to send just 1 group e-mail?

 

[Domenic]

It looks like Dante has provided you with exactly what you want, so that's great.

Cheers!

 

[willow1985]

It looks like Dante has provided you with exactly what you want, so that's great.

Cheers!

I still appreciate your help Domenic, your code almost worked and still showed me I have a lot to learn

Thank you both

 

[willow1985]

Email grouping example: employee1@company.com; employee2@company.com etc.

Sorry I did not specify this earlier.

 

[DanteAmor]

Only a single email will be sent?

 

[willow1985]

Yes, only a single email for the data copied in B1:K (end of data) to all the recipients in column L:

 

[willow1985]

Current Code:

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.Clear
    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
   Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    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
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Columns("C:C").Select
With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    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

MsgBox "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)

    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 paste 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

 

[DanteAmor]

I put your compacted code and only one email will be sent

Sub Flag()
  ' Flag Macro
  '
  Dim msg As String, ans As Variant, LastRowColumnA As Long, lo
  '
  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?"
  If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
 
  Sheets("Automatic Emails").Select
  Range("A2:K" & Rows.Count).Clear
  Sheets("Aerospace Schedule").Select
  For Each lo In ActiveSheet.ListObjects
    lo.AutoFilter.ShowAllData
  Next lo
  ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=12, Criteria1:="Y"
  LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row
  Range("A2:K" & LastRowColumnA).Copy
  Sheets("Automatic Emails").Select
  Range("A2").PasteSpecial Paste:=xlPasteValues
  LastRowColumnA = Cells(Rows.Count, 1).End(xlUp).Row
  With Selection.Borders
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
  End With
  Range("L2:L" & LastRowColumnA).Formula = "=INDEX(C[2],MATCH(RC[-8],C[1],FALSE))"
  With Range("G:G, J:K")
    .NumberFormat = "m/d/yyyy"
    .HorizontalAlignment = xlCenter
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
  End With
 
  'EMAIL CODE
  Call sendmail
 
  MsgBox "Reminder e-mails sent"
End Sub

Sub sendmail()
  Dim OutlookApp As Object, MItem As Object, cad As String
  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
    cad = cad & sh.Range("L" & i).Value & "; "
  Next
  Set OutlookApp = CreateObject("Outlook.Application")
  Set MItem = OutlookApp.CreateItem(0)
  With MItem
    .To = cad
    .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
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