Automate emails from Excel, attach a table

[loribear180]

Hello! I'm hoping someone can guide me into what I'm trying to do, I have data in Excel that I copy&paste into Outlook and then proceed to send an email with the Excel data in a table format (4 columns by 5 rows max).
I'm trying to automate the process and would like to create a mailer list with generic language, and have each email be sent with specific data in table format. I was thinking I could group each little table and have an email address next to it, or something. However, I don't know where to start with this automation process. I'd appreciate if anyone can point me in the right direction

 

[288enzo]

I have much experience figuring this out and playing around with code from Ron de Bruin.

Start here - Mail Range/Selection in the body of the mail

The really important bit is Function RangetoHTML(rng As Range).

Let me know if you need help.

 

[loribear180]

I have much experience figuring this out and playing around with code from Ron de Bruin.

Start here - Mail Range/Selection in the body of the mail

The really important bit is Function RangetoHTML(rng As Range).

Let me know if you need help.

Hi @288enzo

I tried following the link, but couldn't figure it out for the life of me. I was able to create the emails based on this code, however, I am still at a loss on how I would add the actual data in table format into the email.
I fear I might be seeking to do something overly complicated as I'd have to select different data ranges for the table:
-for example, email #1 to Jane Doe should only include the data in rows 1 & 2.
-email #2 to Michael Smith should only include data in rows 3-7.
-email #3 to Roger Kind should only include data in rows 8-15.

Dim xRg As Range
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If (Not Intersect(Target, Range("A1:D4")) Is Nothing) And (Target.Value > 200) Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
   Dim xRgMsg As Range
Dim xCell As Range
Set xRgMsg = Application.InputBox("Please select the address cells:", "Kutools for Excel", , , , , , 8)
    xMailBody = "Good Afternoon," & vbNewLine & vbNewLine & _
              "Below is the available balance as of October 31, 2022, for your respective indirect cost account(s)." & vbNewLine & vbNewLine & _
              "As a reminder, please note that IDC funds do not expire (available funds roll-over year to year). Non-Research (NR) IDC funds can be used to cover the cost of office supplies, educational materials, travel, etc. which support your teaching, research, and other activities at the University. Research (R) IDC funds, though, can only be used to cover the costs of items that support your research at the University." & vbNewLine & vbNewLine & _
              "Please review your available balance(s) and contact our office if you have any questions." & vbNewLine & vbNewLine & _
              "Thank you," & vbNewLine & _
              "OGC"
    On Error Resume Next
For Each xCell In xRgMsg
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
With xOutMail
        .To = xCell.Value
        .CC = ""
        .BCC = ""
        .Subject = "Indirect Cost Account Balance(s)"
        .Body = xMailBody
        .Display
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
Next
On Error GoTo 0
End Sub

 

[288enzo]

Hi @288enzo

I tried following the link, but couldn't figure it out for the life of me. I was able to create the emails based on this code, however, I am still at a loss on how I would add the actual data in table format into the email.
I fear I might be seeking to do something overly complicated as I'd have to select different data ranges for the table:
-for example, email #1 to Jane Doe should only include the data in rows 1 & 2.
-email #2 to Michael Smith should only include data in rows 3-7.
-email #3 to Roger Kind should only include data in rows 8-15.

Dim xRg As Range
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If (Not Intersect(Target, Range("A1:D4")) Is Nothing) And (Target.Value > 200) Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
   Dim xRgMsg As Range
Dim xCell As Range
Set xRgMsg = Application.InputBox("Please select the address cells:", "Kutools for Excel", , , , , , 8)
    xMailBody = "Good Afternoon," & vbNewLine & vbNewLine & _
              "Below is the available balance as of October 31, 2022, for your respective indirect cost account(s)." & vbNewLine & vbNewLine & _
              "As a reminder, please note that IDC funds do not expire (available funds roll-over year to year). Non-Research (NR) IDC funds can be used to cover the cost of office supplies, educational materials, travel, etc. which support your teaching, research, and other activities at the University. Research (R) IDC funds, though, can only be used to cover the costs of items that support your research at the University." & vbNewLine & vbNewLine & _
              "Please review your available balance(s) and contact our office if you have any questions." & vbNewLine & vbNewLine & _
              "Thank you," & vbNewLine & _
              "OGC"
    On Error Resume Next
For Each xCell In xRgMsg
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
With xOutMail
        .To = xCell.Value
        .CC = ""
        .BCC = ""
        .Subject = "Indirect Cost Account Balance(s)"
        .Body = xMailBody
        .Display
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
Next
On Error GoTo 0
End Sub

Try this -

Sub testing()

    Dim xOutApp As Object, xOutMail As Object
    Dim xMailBody As String
    Dim rng As Range
    Dim lastrow As Long, lastrow2 As Long, x As Long
    
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    
    Range("A1:E1").AutoFilter
    
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Range("E2:E" & lastrow).Copy Range("E" & lastrow + 10)
    
    lastrow2 = Cells(Rows.Count, 5).End(xlUp).Row
    
    Range("E" & lastrow + 10 & ":E" & lastrow2).RemoveDuplicates Columns:=1
    
    lastrow2 = Cells(Rows.Count, 5).End(xlUp).Row
    
    xMailBody = "Good Afternoon," & vbNewLine & vbNewLine & _
              "Below is the available balance as of October 31, 2022, for your respective indirect cost account(s)." & vbNewLine & vbNewLine & _
              "As a reminder, please note that IDC funds do not expire (available funds roll-over year to year). Non-Research (NR) IDC funds can be used to cover the cost of office supplies, educational materials, travel, etc. which support your teaching, research, and other activities at the University. Research (R) IDC funds, though, can only be used to cover the costs of items that support your research at the University." & vbNewLine & vbNewLine & _
              "Please review your available balance(s) and contact our office if you have any questions." & vbNewLine & vbNewLine & _
              "Thank you," & vbNewLine & _
              "OGC"
    
    For x = lastrow + 10 To lastrow2
    
        Rows(1).AutoFilter field:=5, Criteria1:=Range("E" & x)
        
        Set rng = Range("A1:E" & lastrow)
        
        eto = Range("E" & x)
        
        Set xOutApp = CreateObject("Outlook.Application")
        Set xOutMail = xOutApp.CreateItem(0)
        
        With xOutMail
        .To = eto
        .CC = ""
        .BCC = ""
        .Subject = "Indirect Cost Account Balance(s)"
        .htmlbody = xMailBody & "<br>" & RangetoHTML(rng) & .htmlbody
        .Display
        End With
    
        Set xOutMail = Nothing
        Set xOutApp = Nothing
        
        eto = ""
        
    Next x
    
    Range("E" & lastrow + 10 & ":E" & lastrow2).ClearContents
    
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
        
End Sub

Function RangetoHTML(rng)
    Dim obj As Object
    Dim txtstr As Object
    Dim File As String
    Dim wb As Workbook
    File = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    Set wb = Workbooks.Add(1)
    With wb.Sheets(1)
        
        rng.Copy
        .Cells(1, 1).PasteSpecial Paste:=8
        .Cells(1, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(1, 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
    With wb.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=File, _
         Sheet:=wb.Sheets(1).Name, _
         Source:=wb.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set obj = CreateObject("Scripting.FileSystemObject")
    Set txtstr = obj.GetFile(File).OpenAsTextStream(1, -2)
    RangetoHTML = txtstr.readall
    txtstr.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    Application.EnableEvents = False
    wb.Close savechanges:=False
    Kill File
    Set txtstr = Nothing
    Set obj = Nothing
    Set wb = Nothing
End Function

If you wanted to change the font in your body you could do something like this -

        .htmlbody = "<span style=""font-size:13px;font-family:Clibri;"">" _
                & xMailBody & "<br>" & RangetoHTML(rng) & .htmlbody

 

[loribear180]

Try this -

Sub testing()

    Dim xOutApp As Object, xOutMail As Object
    Dim xMailBody As String
    Dim rng As Range
    Dim lastrow As Long, lastrow2 As Long, x As Long
  
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
  
    Range("A1:E1").AutoFilter
  
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
  
    Range("E2:E" & lastrow).Copy Range("E" & lastrow + 10)
  
    lastrow2 = Cells(Rows.Count, 5).End(xlUp).Row
  
    Range("E" & lastrow + 10 & ":E" & lastrow2).RemoveDuplicates Columns:=1
  
    lastrow2 = Cells(Rows.Count, 5).End(xlUp).Row
  
    xMailBody = "Good Afternoon," & vbNewLine & vbNewLine & _
              "Below is the available balance as of October 31, 2022, for your respective indirect cost account(s)." & vbNewLine & vbNewLine & _
              "As a reminder, please note that IDC funds do not expire (available funds roll-over year to year). Non-Research (NR) IDC funds can be used to cover the cost of office supplies, educational materials, travel, etc. which support your teaching, research, and other activities at the University. Research (R) IDC funds, though, can only be used to cover the costs of items that support your research at the University." & vbNewLine & vbNewLine & _
              "Please review your available balance(s) and contact our office if you have any questions." & vbNewLine & vbNewLine & _
              "Thank you," & vbNewLine & _
              "OGC"
  
    For x = lastrow + 10 To lastrow2
  
        Rows(1).AutoFilter field:=5, Criteria1:=Range("E" & x)
      
        Set rng = Range("A1:E" & lastrow)
      
        eto = Range("E" & x)
      
        Set xOutApp = CreateObject("Outlook.Application")
        Set xOutMail = xOutApp.CreateItem(0)
      
        With xOutMail
        .To = eto
        .CC = ""
        .BCC = ""
        .Subject = "Indirect Cost Account Balance(s)"
        .htmlbody = xMailBody & "<br>" & RangetoHTML(rng) & .htmlbody
        .Display
        End With
  
        Set xOutMail = Nothing
        Set xOutApp = Nothing
      
        eto = ""
      
    Next x
  
    Range("E" & lastrow + 10 & ":E" & lastrow2).ClearContents
  
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
      
End Sub

Function RangetoHTML(rng)
    Dim obj As Object
    Dim txtstr As Object
    Dim File As String
    Dim wb As Workbook
    File = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    Set wb = Workbooks.Add(1)
    With wb.Sheets(1)
      
        rng.Copy
        .Cells(1, 1).PasteSpecial Paste:=8
        .Cells(1, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(1, 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
    With wb.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=File, _
         Sheet:=wb.Sheets(1).Name, _
         Source:=wb.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set obj = CreateObject("Scripting.FileSystemObject")
    Set txtstr = obj.GetFile(File).OpenAsTextStream(1, -2)
    RangetoHTML = txtstr.readall
    txtstr.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    Application.EnableEvents = False
    wb.Close savechanges:=False
    Kill File
    Set txtstr = Nothing
    Set obj = Nothing
    Set wb = Nothing
End Function

If you wanted to change the font in your body you could do something like this -

        .htmlbody = "<span style=""font-size:13px;font-family:Clibri;"">" _
                & xMailBody & "<br>" & RangetoHTML(rng) & .htmlbody

@288enzo This worked! Now I just need to figure out how why my mailbody isn't coming out as I had initially set it. Is it because adding the table removes the extra spacing??

The "Excel Data Current" is the code output, but I was thinking of formatting it as the "Excel Data Ideal". Would I need to create a mailbody before the table code and a separate mailbody after the table?

Also, you are a life saver, how did you learn VBA? are there courses, or is it mostly through experience and trial/error?

 

[288enzo]

@288enzo This worked! Now I just need to figure out how why my mailbody isn't coming out as I had initially set it. Is it because adding the table removes the extra spacing??

The "Excel Data Current" is the code output, but I was thinking of formatting it as the "Excel Data Ideal". Would I need to create a mailbody before the table code and a separate mailbody after the table?

Also, you are a life saver, how did you learn VBA? are there courses, or is it mostly through experience and trial/error?

I'm using HTML, so you would need HTML coding in your body. I've made a few changes.
Feel free to change the font font-family:Calibri.

Sub testing()

    Dim xOutApp As Object, xOutMail As Object
    Dim xMailBody1 As String, xMailBody2
    Dim rng As Range
    Dim lastrow As Long, lastrow2 As Long, x As Long
    
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    
    Range("A1:E1").AutoFilter
    
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Range("E2:E" & lastrow).Copy Range("E" & lastrow + 10)
    
    lastrow2 = Cells(Rows.Count, 5).End(xlUp).Row
    
    Range("E" & lastrow + 10 & ":E" & lastrow2).RemoveDuplicates Columns:=1
    
    lastrow2 = Cells(Rows.Count, 5).End(xlUp).Row
    
    xMailBody1 = "Good Afternoon,<br><br>" & _
              "Below is the available balance as of October 31, 2022, for your respective indirect cost account(s)."
              
    xMailBody2 = "<br>As a reminder, please note that IDC funds do not expire (available funds roll-over year to year). Non-Research (NR) IDC funds can be used to cover the cost of office supplies, educational materials, travel, etc. which support your teaching, research, and other activities at the University. Research (R) IDC funds, though, can only be used to cover the costs of items that support your research at the University.<br><br>" & _
              "Please review your available balance(s) and contact our office if you have any questions.<br><br>" & _
              "Thank you, OGC"
    
    For x = lastrow + 10 To lastrow2
    
        Rows(1).AutoFilter field:=5, Criteria1:=Range("E" & x)
        
        Set rng = Range("A1:D" & lastrow) 'this is the range that will be inserted into each email.  I edited it to exclude the email column as they would already know.  You can change it back - Range("A1:E" & lastrow)
        
        eto = Range("E" & x)
        
        Set xOutApp = CreateObject("Outlook.Application")
        Set xOutMail = xOutApp.CreateItem(0)
        
        With xOutMail
        .To = eto
        .CC = ""
        .BCC = ""
        .Subject = "Indirect Cost Account Balance(s)"
        .htmlbody = "<span style=""font-size:13px;font-family:Calibri;"">" _
                & xMailBody1 & "<br>" & RangetoHTML(rng) & xMailBody2 & .htmlbody
        .Display
        End With
    
        Set xOutMail = Nothing
        Set xOutApp = Nothing
        
        eto = ""
        
    Next x
    
    Range("E" & lastrow + 10 & ":E" & lastrow2).ClearContents
    
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
        
End Sub

 

[288enzo]

I've learned from trial and error and mostly this site. I've read a rather thick book before, but typically I'll start working on something, run into a road block, and ask a question here. Fluff has been an amazing helper along my journey.

 

[loribear180]

I'm using HTML, so you would need HTML coding in your body. I've made a few changes.
Feel free to change the font font-family:Calibri.

Sub testing()

    Dim xOutApp As Object, xOutMail As Object
    Dim xMailBody1 As String, xMailBody2
    Dim rng As Range
    Dim lastrow As Long, lastrow2 As Long, x As Long
   
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
   
    Range("A1:E1").AutoFilter
   
    lastrow = Cells(Rows.Count, 1).End(xlUp).Row
   
    Range("E2:E" & lastrow).Copy Range("E" & lastrow + 10)
   
    lastrow2 = Cells(Rows.Count, 5).End(xlUp).Row
   
    Range("E" & lastrow + 10 & ":E" & lastrow2).RemoveDuplicates Columns:=1
   
    lastrow2 = Cells(Rows.Count, 5).End(xlUp).Row
   
    xMailBody1 = "Good Afternoon,<br><br>" & _
              "Below is the available balance as of October 31, 2022, for your respective indirect cost account(s)."
             
    xMailBody2 = "<br>As a reminder, please note that IDC funds do not expire (available funds roll-over year to year). Non-Research (NR) IDC funds can be used to cover the cost of office supplies, educational materials, travel, etc. which support your teaching, research, and other activities at the University. Research (R) IDC funds, though, can only be used to cover the costs of items that support your research at the University.<br><br>" & _
              "Please review your available balance(s) and contact our office if you have any questions.<br><br>" & _
              "Thank you, OGC"
   
    For x = lastrow + 10 To lastrow2
   
        Rows(1).AutoFilter field:=5, Criteria1:=Range("E" & x)
       
        Set rng = Range("A1:D" & lastrow) 'this is the range that will be inserted into each email.  I edited it to exclude the email column as they would already know.  You can change it back - Range("A1:E" & lastrow)
       
        eto = Range("E" & x)
       
        Set xOutApp = CreateObject("Outlook.Application")
        Set xOutMail = xOutApp.CreateItem(0)
       
        With xOutMail
        .To = eto
        .CC = ""
        .BCC = ""
        .Subject = "Indirect Cost Account Balance(s)"
        .htmlbody = "<span style=""font-size:13px;font-family:Calibri;"">" _
                & xMailBody1 & "<br>" & RangetoHTML(rng) & xMailBody2 & .htmlbody
        .Display
        End With
   
        Set xOutMail = Nothing
        Set xOutApp = Nothing
       
        eto = ""
       
    Next x
   
    Range("E" & lastrow + 10 & ":E" & lastrow2).ClearContents
   
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
       
End Sub

The HTML and VBA gods hate me I have the error in the picture now

 

[288enzo]

The HTML and VBA gods hate me I have the error in the picture now

It can’t find the function RangeToHTML. Did you add it from my earlier post? That doesn’t change, it can be used with just about anything. The function of it is to take your names rng and add it to an email.

 

[288enzo]

Function RangetoHTML(rng)
    Dim obj As Object
    Dim txtstr As Object
    Dim File As String
    Dim wb As Workbook
    File = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    Set wb = Workbooks.Add(1)
    With wb.Sheets(1)
        
        rng.Copy
        .Cells(1, 1).PasteSpecial Paste:=8
        .Cells(1, 1).PasteSpecial xlPasteValues, , False, False
        .Cells(1, 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
    With wb.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=File, _
         Sheet:=wb.Sheets(1).Name, _
         Source:=wb.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set obj = CreateObject("Scripting.FileSystemObject")
    Set txtstr = obj.GetFile(File).OpenAsTextStream(1, -2)
    RangetoHTML = txtstr.readall
    txtstr.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    Application.EnableEvents = False
    wb.Close savechanges:=False
    Kill File
    Set txtstr = Nothing
    Set obj = Nothing
    Set wb = Nothing
End Function