我需要一些帮助，因为我正在尝试在打开的 Outlook 电子邮件中插入筛选后的 Excel 表格。 我已经设法使用我在网上找到的函数（ExcelRangeToOutlookEmailBody）来做到这一点，但这取代了我在粘贴表格之前收到的消息，而且我也无法在表格上方或下方添加任何文本，所以现在我正在尝试编写一个动态创建 html 表格的子程序，因为这似乎更容易操作，以便在表格之前和之后插入文本。
我有一个表，其中有多个项目属于多个人，我想按每个人过滤表，复制可见行并将其粘贴到打开的电子邮件中。我只想按一个按钮，Excel 使用筛选后的表格创建多封（通常少于 10 封）电子邮件。
我的代码是我在网上找到的东西加上我的一些调整的组合，它动态地构建了 html 表。然而，它只适用于第一个人，并且从那时起就无法构建 html 表 - 它只是重复第一个过滤表。为了简化事情，下面的代码只是 html 表格构建器，其余的我已经弄清楚了（或者我相信）。
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
下面是我需要按人员 ID 过滤的表格（TableMail）。请注意，该表链接到另一个工作表中的另一个表，其中它获取除用户需要输入的截止日期之外的所有值。 最后三行中的空白单元格并不是真正的空，它们包含与其他单元格相同的公式，我只是对空白单元格进行了一些条件格式设置。公式与此类似： =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 | |
代码中还提到了第二个表（People）：
| PersonID | Name | MAIL | Step1 | Step2 |
|---------- |---------- |------------------------------------- |------- |------- |
| 95 | Bart | [email protected] | ide3 | idv2 |
| 96 | Maggie | [email protected] | ide4 | idv3 |
| 97 | Lisa | [email protected] | ide8 | idv1 |
| 98 | Homer | [email protected] | ide3 | idv5 |
| 99 | Marge | [email protected] | ide5 | idv4 |
| 100 | Flanders | [email protected] | ide2 | |
| 101 | Peter | nomorefunnynames@gmail | ide1 | |
| 102 | Lois | [email protected] | ide11 | |
| 103 | Meg | [email protected] | ide9 | |
| 104 | Chris | [email protected] | ide6 | |
| 105 | Brian | [email protected] | ide7 | |
这是上面代码的输出
我有 4 个人的 ID，但是这个循环总是输出同一个表，而不是每个人一张表：
| 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 |
问题似乎出在我组装表头和表体时：
Set finalTable = Union(rngHdr, rngDat)
我已经检查过，rngHdr 和 rngDat 看起来都不错，但 FinalTable 似乎只包含标题，这很奇怪，因为它输出了前一个人的项目。
我现在被困在这里，并没有真正理解为什么循环只在第一次通过时起作用。
代码的其余部分似乎工作正常，它确实按每个人员 ID 按顺序过滤 TableMail，并且通过我的完整代码，我确实从第二个人员表中获取了我需要的信息，并且能够打开 4 封新电子邮件，每封都带有正确的收件人、主题和称呼，我还可以将表格与电子邮件文本的其余部分连接起来。我只是不明白为什么它不断粘贴相同的第一个过滤表。
使用单个表格来说明并将功能分解为我认为有意义的单独方法：
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