using VBA how can I send a selection of Excel Cells to an Email Body with html formatting?

Question

I have grabbed a range of cells from my Excel Worksheet, but for each cell in the range I am wanting to add a string + opening html, then add cell 1 from range I grabbed from my Excel sheet, then add closing html, and finally move to cell 2 in the range. Repeating the process for the next string + opening html + cell 2 + closing html.

The method I am using currently is incorrect as it is placing ALL the strings, html and the current cell to the body every time, and then moving to cell 2 in the range!

Here is my code so far:

Sub Email_Figures_Click()

    'Lets dim the things we need
    Dim CDO_Mail As Object
    Dim CDO_Config As Object
    Dim SMTP_Config As Variant
    Dim strSubject As String
    Dim strFrom As String
    Dim strTo As String
    Dim strCc As String
    Dim strBcc As String
    Dim myRng As Range

    'To begin with, we want a clean Range, meaning nothing inside
    Set myRng = Nothing

    'So I am setting the cells I wish to use from the Excel Sheet Monthly Figures
    Set myRng = Sheets("Monthly Figures").Range("B5,B6,B8,B9,B10,B11,B12,B13,B15,B17,B18,B19,B20,B22,B23,B25").SpecialCells(xlCellTypeVisible)

    'Error Handling message, just incase
    If myRng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

    html_text = _
        "**HIDDEN** Monthly Figures

"

    'NOTE: UPDATED THE LOOP AND HTML BELOW FOR BODY

    For Each Row In myRng.Rows
        For Each cell In Row.Cells
            html_text = html_text & _
                "Month: " & _
                cell.Text & _
                "

"
            html_text = html_text & _
                "Purchases Total: " & _
                cell.Text & _
                "
"
            html_text = html_text & _
                "Purchases Count: " & _
                cell.Text & "

"
            html_text = html_text & _
                "Invoices Total: " & _
                cell.Text & "
"
            html_text = html_text & _
                "Paid Invoices Total: " & _
                cell.Text & _
                "
"
            html_text = html_text & _
                "Unpaid Invoices Total: " & _
                cell.Text & _
                "
"
            html_text = html_text & _
                "Sales Invoices Count: " & _
                cell.Text & _
                "
"
            html_text = html_text & _
                "Paid Sales Invoices Count: " & _
                cell.Text & _
                "
"
            html_text = html_text & _
                "Unpaid Sales Invoices Count: " & _
                cell.Text & _
                "

"
            html_text = html_text & _
                "Tax Receipts Total: " & _
                cell.Text & _
                "

"
            html_text = html_text & _
                "Float Money Starting Balance: " & _
                cell.Text & _
                "
"
            html_text = html_text & _
                "Float Money Current Balance: " & _
                cell.Text & _
                "
"
            html_text = html_text & _
                "Float Money In: " & _
                cell.Text & _
                "
"
            html_text = html_text & _
                "Float Money Out: " & _
                cell.Text & _
                "

"
            html_text = html_text & _
                "Cash Sales Total: " & _
                cell.Text & _
                "
"
            html_text = html_text & _
                "Cash Sales Count: " & _
                cell.Text & _
                "

"
            html_text = html_text & _
                "Months Evaluation: " & _
                cell.Text & _
                "
"
        Next cell
    Next Row

    'Some more sexy error handling
    Set CDO_Mail = CreateObject("CDO.Message")
    On Error GoTo Error_Handling

    'Sets our SMTP settings so we can send emails....and stuff.
    Set CDO_Config = CreateObject("CDO.Configuration")
    CDO_Config.Load -1

    Set SMTP_Config = CDO_Config.Fields

    With SMTP_Config
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "**HIDDEN**"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "HIDDEN"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "HIDDEN"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
        .Update
    End With

    'This is where I made myself a cup of tea because I was getting tired! :D
    With CDO_Mail
        Set .Configuration = CDO_Config
    End With

    'And finally this is the email subject, to, from, body, cc, and any bcc
    CDO_Mail.Subject = "HIDDEN"
    CDO_Mail.From = "HIDDEN"
    CDO_Mail.To = "HIDDEN"
    CDO_Mail.HTMLBody = html_text
    CDO_Mail.CC = ""
    CDO_Mail.BCC = ""

    'Send the message
    CDO_Mail.Send

    'Error handling
    Error_Handling:
    If Err.Description <> "" Then MsgBox Err.Description

End Sub


Sub Print_Figures_Click()
ActiveWindow.SelectedSheets.PrintOut ' print
End Sub

(Note: This code has been updated 18/07/2018 to show an amended For Each Row In myRng.Rows & HTML being used, but still requires further amendments.)

This 'may' be a possible part-solution but I am not sure how to implement it correctly:

' Declare an array with 18 elements including 0 as the first.
Dim my_body_text(17) As String

' Assign values to each element.
my_body_text(0) = _
    "**HIDDEN** Monthly Figures

"
my_body_text(1) = my_body_text(0) & _
    "Month: " & _
    cell.Text & _
    "

"
my_body_text(2) = my_body_text(1) & _
    "Purchases Total: " & _
    cell.Text & _
    "
"
my_body_text(3) = my_body_text(2) & _
    "Purchases Count: " & _
    cell.Text & _
    "

"
my_body_text(4) = my_body_text(3) & _
    "Invoices Total: " & _
    cell.Text & _
    "
"
my_body_text(5) = my_body_text(4) & _
    "Paid Invoices Total: " & _
    cell.Text & _
    "
"
my_body_text(6) = my_body_text(5) & _
    "Unpaid Invoices Total: " & _
    cell.Text & _
    "
"
my_body_text(7) = my_body_text(6) & _
    "Sales Invoices Count: " & _
    cell.Text & _
    "
"
my_body_text(8) = my_body_text(7) & _
    "Paid Sales Invoices Count: " & _
    cell.Text & _
    "
"
my_body_text(9) = my_body_text(8) & _
    "Unpaid Sales Invoices Count: " & _
    cell.Text & _
    "

"
my_body_text(10) = my_body_text(9) & _
    "Tax Receipts Total: " & _
    cell.Text & _
    "

"
my_body_text(11) = my_body_text(10) & _
    "Float Money Starting Balance: " & _
    cell.Text & _
    "
"
my_body_text(12) = my_body_text(11) & _
    "Float Money Current Balance: " & _
    cell.Text & _
    "
"
my_body_text(13) = my_body_text(12) & _
    "Float Money In: " & _
    cell.Text & _
    "
"
my_body_text(14) = my_body_text(13) & _
    "Float Money Out: " & _
    cell.Text & _
    "

"
my_body_text(15) = my_body_text(14) & _
    "Cash Sales Total: " & _
    cell.Text & _
    "
"
my_body_text(16) = my_body_text(15) & _
    "Cash Sales Count: " & _
    cell.Text & _
    "

"
my_body_text(17) = my_body_text(16) & _
    "Months Evaluation: " & _
    cell.Text & _
    "
"

' Create a 10-element integer array.
Dim i As Integer

' Add info & increase by 1 each time.
For i = 0 To 17
    '
    ' ADD THE CELL INTO STRING HERE SOMEHOW!
    '
    '
    my_body_text(i) = my_body_text(i) + 1
Next i

Any help is appreciated!

Update on the code being used now as of 19/07/2018:

This version is correctly sending the email, and correctly sending each of the Cell.Text, but for some reason it is not sending the tags or the strings within the tags. For example: instead of placing the full string "Tax Receipts Total: " & Cell.Text from Case 10 into the html_text, it is placing: Month: from the Case 1 without the tags in every time, and then adding the correctly updated Cell.Text afterwards. Its almost working... Can you advise what I am missing?

(And is there a way to put copy the currency symbol also? As only a question mark displays for currency symbols other than $ or £ copied. I know the unicode for what I am wanting is U+0E3F. Can this just be placed in a string?)

'Begin Email button
Sub Email_Figures_Click()

'Dims the things we need
Dim CDO_Mail As Object
Dim CDO_Config As Object
Dim SMTP_Config As Variant
Dim strSubject As String
Dim strFrom As String
Dim strTo As String
Dim strCc As String
Dim strBcc As String
Dim myRng As Range
Dim CaseRange As Integer

'To begin with, we want a clean Range, meaning nothing inside
Set myRng = Nothing

'So I am setting the cells I wish to use from the Excel Sheet Monthly Figures
Set myRng = Sheets("Monthly Figures").Range("B2,B5,B6,B8,B9,B10,B11,B12,B13,B15,B17,B18,B19,B20,B22,B23,B25").SpecialCells(xlCellTypeVisible)

'Error Handling message, just incase
If myRng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
End If

'Sets the email body title (inside the html_text)
html_text = "**HIDDEN** Monthly Figures

"


'Defaults the CaseRange to 1
CaseRange = 1

For Each Row In myRng.Rows 'For each Row
    For Each Cell In Row.Cells 'And for each cell in the Row
        Select Case CaseRange 'Select a Case from our CaseRange
            Case 1
                html_text = html_text & "Month: " & Cell.Text & "

"
            Case 2
                html_text = html_text & "Purchases Total: " & Cell.Text & "
"
            Case 3
                html_text = html_text & "Purchases Count: " & Cell.Text & "

"
            Case 4
                html_text = html_text & "Invoices Total: " & Cell.Text & "
"
            Case 5
                html_text = html_text & "Paid Invoices Total: " & Cell.Text & "
"
            Case 6
                html_text = html_text & "Unpaid Invoices Total: " & Cell.Text & "
"
            Case 7
                html_text = html_text & "Sales Invoices Count: " & Cell.Text & "
"
            Case 8
                html_text = html_text & "Paid Sales Invoices Count: " & Cell.Text & "
"
            Case 9
                html_text = html_text & "Unpaid Sales Invoices Count: " & Cell.Text & "

"
            Case 10
                html_text = html_text & "Tax Receipts Total: " & Cell.Text & "

"
            Case 11
                html_text = html_text & "Float Money Starting Balance: " & Cell.Text & "
"
            Case 12
                html_text = html_text & "Float Money Current Balance: " & Cell.Text & "
"
            Case 13
                html_text = html_text & "Float Money In: " & Cell.Text & "
"
            Case 14
                html_text = html_text & "Float Money Out: " & Cell.Text & "

"
            Case 15
                html_text = html_text & "Cash Sales Total: " & Cell.Text & "
"
            Case 16
                html_text = html_text & "Months Evaluation: " & Cell.Text & "
"
            Case Else
               html_text = html_text & "Error: Cannot find the Case Cell Number to import to email"
        End Select
    Next Cell 'Jump to the next cell and repeat the the process
Next Row ' Jump to next Row and repeat the process


'error handling
Set CDO_Mail = CreateObject("CDO.Message")
On Error GoTo Error_Handling

'Sets our SMTP settings so we can send emails
Set CDO_Config = CreateObject("CDO.Configuration")
CDO_Config.Load -1

Set SMTP_Config = CDO_Config.Fields

'Settings for sending the email
With SMTP_Config
 .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "**HIDDEN**"
 .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "**HIDDEN**"
 .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "**HIDDEN**"
 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
 .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
 .Update
End With

'Sets the config
With CDO_Mail
 Set .Configuration = CDO_Config
End With

'Defines Email Attributes
CDO_Mail.Subject = "**HIDDEN** Monthly Figures"
CDO_Mail.From = "**HIDDEN**"
CDO_Mail.To = "**HIDDEN**"
CDO_Mail.HTMLBody = html_text
CDO_Mail.CC = ""
CDO_Mail.BCC = ""

'Sends the email
CDO_Mail.Send

'Error handling and email sent successfully confirmation
Error_Handling:
If Err.Description <> "" Then MsgBox Err.Description Else MsgBox "Message sent successfully"

'End the button
End Sub


Sub Print_Figures_Click()
ActiveWindow.SelectedSheets.PrintOut ' print
End Sub

Screenshot below of the email output

Dummy Data that is being passed by email

Updated 20/07/2017 to make my Case selction more like what @Paul has suggested

@Paul

Notes & Updates: CSS style related html doesn't seem to work. For example:

& , These simply do not want to work within the Case Selections. I would have to use . This being said, it picks up the very first HTML tag in the first Case only that is being used and applies to everything in html_text after that. Despite having closing HTML tags!

I don't see any difference with using my 1 Range of all the cells, and using your 2 Ranges , 1 for Headers and 1 for Totals. It seems to do the same thing. I have tried both options though just to eliminate this option. I have then gone and added all Title Headings for each total into the Range also, so the range cell count has now doubled.

From your last update to your answer explains the Cases a lot more than what I was able to find anywhere else online, so thanks for that. I have now changed my Cases to make them similar to your own as much as possible.

Below is the full code to date:

'Begin Email button Sub Email_Figures_Click() 'Dims the things we need Dim CDO_Mail As Object Dim CDO_Config As Object Dim SMTP_Config As Variant Dim strSubject As String Dim strFrom As String Dim strTo As String Dim strCc As String Dim strBcc As String Dim myRng As Range Dim CaseRange As Integer 'To begin with, we want a clean Range, meaning nothing inside Set myRng = Nothing 'So I am setting the cells I wish to use from the Excel Sheet Monthly Figures Set myRng = Sheets("Monthly Figures").Range("A2,B2,A5,B5,A6,B6,A8,B8,A9,B9,A10,B10,A11,B11,A12,B12,A13,B13,A15,B15,A17,B17,A18,B18,A19,B19,A20,B20,A22,B22,A23,B23,A25,B25").SpecialCells(xlCellTypeVisible) 'Error Handling message, just incase If myRng Is Nothing Then MsgBox "The selection is not a range or the sheet is protected" & _ vbNewLine & "please correct and try again.", vbOKOnly Exit Sub End If 'Sets the email body title (inside the html_text) html_text = "**HIDDEN** Monthly Figures " 'Defaults the CaseRange to 1 CaseRange = 1 For Each Row In myRng.Rows 'For each Row For Each Cell In Row.Cells 'And for each cell in the Row Select Case CaseRange 'Month Title Heading Case 1 html_text = html_text & _ "" & _ Cell.Text & _ "" 'The Month Case 2 html_text = html_text & _ "" & _ Cell.Text & _ "" 'All other Title Headings Case 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31, 33 html_text = html_text & _ "" & _ Cell.Text & _ "" 'All the Black Totals Case 4, 6, 8, 14, 20, 22, 24, 32, 34 html_text = html_text & _ "" & _ Cell.Text & _ "" 'All the Red Totals Case 12, 18, 28, 30 html_text = html_text & _ "" & _ Cell.Text & _ "" 'All the Green Totals Case 10, 16, 26 html_text = html_text & _ "" & _ Cell.Text & _ "" End Select Next Cell 'Jump to the next cell and repeat the the process Next Row ' Jump to next Row and repeat the process 'Close our html & body tags before adding to email html_text = html_text & "" 'error handling Set CDO_Mail = CreateObject("CDO.Message") On Error GoTo Error_Handling 'Sets our SMTP settings so we can send emails Set CDO_Config = CreateObject("CDO.Configuration") CDO_Config.Load -1 Set SMTP_Config = CDO_Config.Fields 'Settings for sending the email With SMTP_Config .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "**HIDDEN**" .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "**HIDDEN**" .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "**HIDDEN**" .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False .Update End With 'Sets the config With CDO_Mail Set .Configuration = CDO_Config End With 'Defines Email Attributes CDO_Mail.Subject = "**HIDDEN** Monthly Figures" CDO_Mail.From = "**HIDDEN**" CDO_Mail.To = "**HIDDEN**" CDO_Mail.HTMLBody = html_text CDO_Mail.CC = "" CDO_Mail.BCC = "" 'Sends the email CDO_Mail.Send 'Error handling and email sent successfully confirmation Error_Handling: If Err.Description <> "" Then MsgBox Err.Description Else MsgBox "Message sent successfully" 'End the button End Sub

And here is the outputted email:

user1945782 · Accepted Answer

All those Next statements are going to cause you a problem.

What I would say is put the title for the statistic in the cell above, then you can include that in the range. From there it's simply a case of...

Const colStart As Integer = 5: Const colEnd As Integer = 25
Const rowTitle As Integer = 2: Const rowData As Integer = 3

Dim x As Integer
Dim msg As String
For x = colStart To colEnd
    If Cells(rowTitle, x) <> "" Then
        msg = msg & Cells(rowTitle, x) & _
            "" & Cells(rowData, x) & ""
    End If
Next x

Alternatively you could create a list of strings that you want to use and split them...

Dim strTitles() As String
strTitles = Split("List of titles,and other,things", ",")
Dim x As Integer
For x = colStart To colEnd
    ...

Or you could keep a reference sheet for things like titles and switch between the two using a similar method to that mentioned above...

For x = colStart To colEnd
    If Worksheets(0).Cells(rowTitle, x) <> "" Then
        msg = msg & Worksheets(0).Cells(rowTitle, x) & _
            "" & _
            Worksheets(1).Cells(rowData, x) & _
            ""
    End If
Next x

Yet another option would be to have a worksheet to control all of your settings. For example...

And then read the values from this to get your values from the appropriate location...

Dim strSht As String
Dim row As Integer, cols As Integer, x As Integer
strSheet = Worksheets("MySettings").Cells(1,1)
row = Worksheets("MySettings").Cells(2,1)
cols = Worksheets("MySettings").Cells(3,1)
For x = 4 to 3 + cols
    msg = msg & _
        "" & _
            Worksheets("MySettings").Cells(x,1) & _
        "" & _
        Worksheets(strSht).Cells(row, Worksheets("MySettings").Cells(x,1))
Next x

In Response To Update (19/07/2018)

You've missed the point completely. There's absolutely no reason to have a loop if you're going to independently format every single string in this manner.

Design

Firstly, design is crucial - you simply do not want to be changing too many font settings. Rather than use font-size: 22pt; weight: bold;, consider using the

tag. Likewise for the slightly smaller font, use

. For anything that needs to stand out, use , and use for anything that needs emphasising (you could use the or tags if you prefer, as their use is becoming more accepted once again, though it's a love hate relationship with some, though in your case their use would be semantically specific). Changing font size way too many times makes your email more difficult to read.

If you have to use colour, then only use two - black and another colour. Again, changing the colour too frequently makes it messy (IMO). For instance, the financial developers that I know, tend to only use black and red, and guess which text is usually red?...

Using Select Case

The idea behind Select Case was to limit the amount of work you had to do. In your case this simply isn't going to work unless you change your design. The reason I recommended it was to try and help you limit that amount of reformatting you were about to do.

Select Case is intended to work with a small number of options from a larger total. For instance, in your case, you could have used...

Const rowHead As Integer = theRowNumberThatHasTheHeadingsOnIt Dim rowData As Integer, colStart, colEnd rowData = theRowNumberThatHasTheDataOnIt colStart = theFirstColumnInTheList colEnd = theLastColumnInTheList Dim msgText As String For x = colStart To colEnd Select Case x Case 1 msgText = _ "" & _ Cell(x, rowData) & _ "" Case 2 msgText = _ "" & _ Cell(x, rowData) & _ "" Case 3, 4, 7, 10, 11, 12, 16 msgText = _ "" & _ Cell(x, rowHead) & ": " & _ "" & _ Cell(x, rowData) Case 5, 8, 13 msgText = _ "" & _ Cell(x, rowHead) & ": " & _ "" & _ Cell(x, rowData) Case 6, 9, 14, 15 msgText = _ "" & _ Cell(x, rowHead) & ": " & _ "" & _ Cell(x, rowData) Case Else 'Not really necessary, as you really want to skip any columns 'that you don't want, but your could put whatever doesn't quite 'fit here. End Select htmlMsg = htmlMsg & msgText Next x

Notice the way I've used the Select Case statement - if particular columns in your list are not required in your email, then do not include them in the Case statement lines, that way they'll be skipped over.

I can't make it any clearer than that, really.

Good reading, though, would be the PHP switch statement that I included in the comments for your post.

using VBA how can I send a selection of Excel Cells to an Email Body with html formatting?

Answers (1)

In Response To Update (19/07/2018)

Related Questions