I need a little help as I'm trying to insert a filtered Excel table in a open Outlook email message. I've managed to do that using a function I found online (ExcelRangeToOutlookEmailBody), but that replaces the message I had before pasting the table and I'm also unable to add any text above or below the table, so now I'm trying to write a sub that dynamically creates a html table, as this seems easier to manipulate in order to insert text before and after the table.
I have a table with a number of projects attributed to a number of persons, and I want to filter the table by each person, copy the visible rows and paste it to an open e-mail message. I want to just press a button to Excel create several (usually less than 10) email messages with the filtered table.
The code I have is a mix of things I found online plus some tweaking of mine, and it builds the html table dynamically. However, it only works for the first person and it fails to build the html table from then on - it just repeats the first filtered table. To simplify things, the code below it's just the html table builder, the rest I got figured out (or so I believe).
Sub HtmlTableBuilder()
Dim Wb As Workbook
Dim ws As Worksheet
Dim wsBD As Worksheet
Dim Table As ListObject
Dim TableMail As ListObject
Dim Col As Range
Dim count As Integer
Dim finalTable As Range
Dim result As Variant
Dim values As Variant
Dim dic As Scripting.Dictionary
Dim valCounter As Long
Dim rngHdr As Range
Dim rngDat As Range
Set Wb = Workbooks("MyWorkbook.xlsb")
Set ws = Wb.Worksheets("FL")
Set wsBD = Wb.Worksheets("BD") 'Person database
Set Table = ws.ListObjects("TabMail") 'Table to be filtered, copied and pasted to email
Set TableMail = wsBD.ListObjects("People") 'Table with names, ID and emails of each person
Set Col = Range("TabMail[PersonID]") 'Column with the IDs
Set dic = New Scripting.Dictionary ' Add reference to MS Scripting Runtime
'Extract all person names from an array
values = ws.Range("G5:G1000").Value2 'Value2 is faster than Value
dic.CompareMode = BinaryCompare 'Set the comparison mode to case-sensitive
For valCounter = LBound(values) To UBound(values) 'Loop to extract name of persons
If Not dic.Exists(values(valCounter, 1)) Then 'Check if the name is already in the dictionary
dic.Add values(valCounter, 1), 0 'Add the new name as key, with a dummy value of 0
End If
Next valCounter
result = dic.Keys 'Extract the dictionary's keys as a 1D array
count = UBound(result) 'number of persons
'Filter a table by a person name a build a html table with the visible data to send via email
i = 0
Do While i <= count - 1
With Range("A4") 'table first cell is A4; count = number of persons
Col.AutoFilter Field:=7, Criteria1:=result(i) 'filters table by person i
Set rng = Table.HeaderRowRange 'gets the table header
Set rngHdr = rng.Resize(, 6) 'discards last column
Set rng = Table.DataBodyRange.SpecialCells(xlCellTypeVisible) 'gets table visible celss
Set rngDat = rng.Resize(, 6) 'discards last column
Set finalTable = Union(rngHdr, rngDat) 'joins header and body
'loop to build html tables
R = 0 'initializes row counter
If finalTable.Rows.count > 1 Then 'condition to check if filtered table isn't empty
htmlstr = "<table border=1 style='border-collapse: collapse'>" 'html string start
For Each rngrow In finalTable.Rows 'loop rows
c = 0: R = R + 1 'Initializes row & column counter
htmlstr = htmlstr & "<tr>" 'html string row beginning
For Each rngcol In finalTable.Columns 'loop columns to each row
c = c + 1
rngvalue = finalTable(R, c).Value
If R = 1 Then 'checks if is first row to format as header
htmlstr = htmlstr & "<th>" & rngvalue & "</th>"
Else 'formats as body row
htmlstr = htmlstr & "<td>" & rngvalue & "</td>"
End If
Next rngcol
htmlstr = htmlstr & "</tr>" 'html string row ending
Next rngrow
htmlstr = htmlstr & "</table>" 'html string table ending
End If
Debug.Print htmlstr 'Debug to output results to immediate window
End With
i = i + 1
Loop
End Sub
Below is the table (TableMail) that I need to filter by person ID. Note that this table is linked to another table in another worksheet where it gets all it's values except the deadline, which the user needs to enter. Blank cells in the last three rows are not really empty, they contain the same formulas as the other cells, I just have some conditional formatting on blank cells. The formulas are similar to this one: =IF(MyWorkbook.xlsb!TabMail[@[Project_ID]]="";"";"All")
| Table | Project_ID | Task Assigned | Qtty 1 | Qyy2 | Deadline | PersonID |
|---------- |------------ |--------------- |-------- |------ |----------------- |---------- |
| Project2 | 790403 | All | 20 | 30 | 06/01/24 13:00 | 104 |
| Project2 | 790536 | All | 40 | 50 | 06/01/24 13:00 | 104 |
| Project1 | 790539 | All | 2 | 0 | 06/01/24 13:00 | 104 |
| Project2 | 790661 | All | 224 | 1,2 | 09/02/24 13:00 | 104 |
| Project1 | 790685 | All | 1 | 0 | 09/02/24 13:00 | 103 |
| Project1 | 790977 | All | 0 | 19,8 | 09/02/24 13:00 | 103 |
| Project2 | 799103 | All | 299 | 4,8 | 09/02/24 13:00 | 103 |
| Project1 | 799372 | All | 35 | 0,6 | 06/01/24 13:00 | 102 |
| Project1 | 799420 | All | 0 | 87 | 06/01/24 13:00 | 102 |
| Project1 | 790691 | All | 56 | 40,2 | 06/01/24 13:00 | 101 |
| Project1 | 790864 | All | 15 | 0,6 | 09/02/24 13:00 | 101 |
| Project1 | 790907 | All | 267 | 3,6 | 09/02/24 13:00 | 101 |
| | | | | | xx/xx/24 13:00 | |
| | | | | | xx/xx/24 13:00 | |
| | | | | | xx/xx/24 13:00 | |
There is also a second table mentioned in the code (People):
| PersonID | Name | MAIL | Step1 | Step2 |
|---------- |---------- |------------------------------------- |------- |------- |
| 95 | Bart | blablablabla@gmail.com | ide3 | idv2 |
| 96 | Maggie | dummy.dummy@gmail.com | ide4 | idv3 |
| 97 | Lisa | fake_fake@gmail.com | ide8 | idv1 |
| 98 | Homer | placeholder@gmail.com | ide3 | idv5 |
| 99 | Marge | notimportant@outlook.com | ide5 | idv4 |
| 100 | Flanders | noneofyoubusiness@iol.com | ide2 | |
| 101 | Peter | nomorefunnynames@gmail | ide1 | |
| 102 | Lois | ranoutofjokes@outlook.com | ide11 | |
| 103 | Meg | wastingtoomuchtimewiththis@gmai.com | ide9 | |
| 104 | Chris | lackingimagination@gmail.com | ide6 | |
| 105 | Brian | gladitsover@gmail.com | ide7 | |
Here's the output of the above code
I have IDs of 4 persons, but this loop always outputs this same table, instead of one table for each person:
| Project | Project_ID | Task Assigned | Qtty 1 | Qtty 2 | Deadline |
|---------- |------------ |--------------- |-------- |-------- |------------------- |
| Project2 | 790403 | All | 20 | 30 | 06/01/24 13:00:00 |
| Project2 | 790536 | All | 40 | 50 | 06/01/24 13:00:00 |
| Project1 | 790539 | All | 2 | 0 | 06/01/24 13:00:00 |
| Project2 | 790661 | All | 224 | 1,2 | 09/02/24 13:00:00 |
The problem seems to be when I assemble the header and the body of the table:
Set finalTable = Union(rngHdr, rngDat)
I've checked and both rngHdr and rngDat seem OK, but finalTable only seems to contain the header which is strange because it outputs the previous person projects.
I am now stuck here not really understanding why the loop only works on its first pass.
The rest of the code seems to work fine, it does filter the TableMail sequentially by each Person ID and with my complete code I do get the information I need from the second People table and am able to open 4 new email messages, each with the right recipient, subject and salutation, and I am also able to concatenate the table with the rest of the email text. I just don't understand why it keeps pasting the same first filtered table.
Using a single table to illustrate and breaking down the functionality into separate methods where I think it makes sense:
Sub HtmlTableBuilder()
Dim Wb As Workbook, ws As Worksheet
Dim Table As ListObject, Col As ListColumn, html As String
Dim dic As Object, rngDat As Range, rngVis As Range, k
Set Wb = ThisWorkbook 'Workbooks("MyWorkbook.xlsb")
Set ws = Wb.Worksheets("FL")
Set Table = ws.ListObjects("TabMail") 'Table to be filtered
Set Col = Table.ListColumns("PersonID") 'Column with the IDs
Set dic = UniquesFromRange(Col.DataBodyRange) 'get unique values
For Each k In dic.Keys 'loop over dictionary keys
Table.Range.AutoFilter Field:=Col.Index, Criteria1:=k
Set rngVis = Table.Range.SpecialCells(xlCellTypeVisible)
html = AsHtmlTable(rngVis)
If Len(html) > 0 Then
Debug.Print html
Debug.Print "---------------------"
Else
Debug.Print "No rows for " & k 'should never happen....
End If
Next k
Table.AutoFilter.ShowAllData
End Sub
'Convert a range `rng` to html
' `rng` should include headers on row#1: if only one row then no html is created
Function AsHtmlTable(rng As Range) As String
Dim html As String, rw As Range, c As Range, tag As String
If rng.Cells.count = rng.Rows(1).Cells.count Then Exit Function 'nothing to build...
html = "<table border=1 style='border-collapse: collapse'>"
tag = "th" 'headers to start....
For Each rw In rng.Rows
html = html & " <tr>"
For Each c In rw.Cells
html = html & "<" & tag & ">" & c.Value & "</" & tag & ">"
Next c
html = html & "</tr>" & vbLf
tag = "td" 'regular td for rest of rows
Next rw
AsHtmlTable = html & "</table>"
End Function
'return a dictionary object with all unique values from `rng`
Function UniquesFromRange(rng As Range) As Object
Dim c As Range, tmp
Set UniquesFromRange = CreateObject("scripting.dictionary")
UniquesFromRange.CompareMode = 0 'vbBinaryCompare: case-insensitive
For Each c In rng.Cells
tmp = Trim(c.Value)
If Len(tmp) > 0 Then
If Not UniquesFromRange.Exists(tmp) Then UniquesFromRange.Add tmp, 1
End If
Next c
End Function