Excel VBA动态生成HTML表格重复输出问题求助

问题背景 #

需求为按人员筛选Excel项目表格，为每位人员生成包含对应筛选表格的Outlook邮件，点击按钮批量创建（通常少于10封）。此前使用ExcelRangeToOutlookEmailBody函数会覆盖邮件原有内容且无法在表格前后添加文本，因此编写了动态生成HTML表格的VBA子程序，但仅首次循环能生成正确的人员筛选表格，后续循环重复输出首次结果。

现有代码 #

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

数据表格 #

待筛选项目表格（TabMail） #

人员信息表格（People） #

问题根源 #

1. htmlstr未初始化：循环中没有每次重置htmlstr，导致后续循环会追加之前的内容，或残留首次循环的表格结构。
2. Union后的Range访问错误：finalTable = Union(rngHdr, rngDat)生成的是不连续的Range对象，用finalTable(R,c)的索引方式访问会出错，因为不连续Range的行列索引不是连续的，会返回错误区域的值。
3. 可见行获取逻辑隐患：Table.DataBodyRange.SpecialCells(xlCellTypeVisible)在筛选后如果没有可见行会报错，且处理不连续区域时容易出问题。

修复后的代码 #

Sub HtmlTableBuilder_Fixed()

Dim Wb As Workbook
Dim ws As Worksheet
Dim wsBD As Worksheet
Dim Table As ListObject
Dim TableMail As ListObject
Dim dic As Scripting.Dictionary
Dim values As Variant
Dim valCounter As Long
Dim result As Variant
Dim count As Integer
Dim i As Integer
Dim htmlstr As String
Dim headerRow As Range
Dim dataRow As Range
Dim cell As Range
Dim colIdx As Integer

Set Wb = Workbooks("MyWorkbook.xlsb")
Set ws = Wb.Worksheets("FL")
Set wsBD = Wb.Worksheets("BD")
Set Table = ws.ListObjects("TabMail")
Set TableMail = wsBD.ListObjects("People")
Set dic = New Scripting.Dictionary

' 获取唯一PersonID（从表格的PersonID列提取，更准确）
values = Table.ListColumns("PersonID").DataBodyRange.Value2
dic.CompareMode = BinaryCompare

For valCounter = LBound(values) To UBound(values)
    If Not IsEmpty(values(valCounter, 1)) And Not dic.Exists(values(valCounter, 1)) Then
        dic.Add values(valCounter, 1), 0
    End If
Next valCounter

result = dic.Keys
count = UBound(result)

' 循环处理每个PersonID
i = 0
Do While i <= count
    ' 重置HTML字符串
    htmlstr = ""
    ' 筛选表格
    Table.Range.AutoFilter Field:=Table.ListColumns("PersonID").Index, Criteria1:=result(i)
    
    ' 仅当有可见数据行时构建表格
    On Error Resume Next
    Set dataRow = Table.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not dataRow Is Nothing Then
        ' 初始化HTML表格
        htmlstr = "<table border=1 style='border-collapse: collapse;'>"
        
        ' 添加表头（取前6列）
        htmlstr = htmlstr & "<tr>"
        For colIdx = 1 To 6
            htmlstr = htmlstr & "<th>" & Table.HeaderRowRange.Cells(1, colIdx).Value & "</th>"
        Next colIdx
        htmlstr = htmlstr & "</tr>"
        
        ' 添加数据行（遍历每个可见行的前6列）
        For Each dataRow In Table.DataBodyRange.SpecialCells(xlCellTypeVisible).Rows
            htmlstr = htmlstr & "<tr>"
            For colIdx = 1 To 6
                htmlstr = htmlstr & "<td>" & dataRow.Cells(1, colIdx).Value & "</td>"
            Next colIdx
            htmlstr = htmlstr & "</tr>"
        Next dataRow
        
        ' 闭合表格标签
        htmlstr = htmlstr & "</table>"
    End If
    
    ' 输出调试信息
    Debug.Print "PersonID: " & result(i) & vbCrLf & htmlstr & vbCrLf
    
    ' 清理变量，避免残留引用
    Set dataRow = Nothing
    i = i + 1
Loop

' 关闭筛选
Table.Range.AutoFilter

End Sub

关键修改点 #

• 每次循环重置htmlstr：确保每个邮件的HTML表格都是独立生成的。
• 直接遍历ListObject的可见行：避免使用Union后的不连续Range，改用Table.DataBodyRange.SpecialCells(xlCellTypeVisible).Rows逐个访问可见行，确保数据正确。
• 从表格列提取PersonID：替代原代码中固定范围G5:G1000，直接从ListObject的PersonID列提取，更准确且适配表格行数变化。
• 增加错误处理：避免筛选后无可见行时SpecialCells报错。
• 明确列索引：直接指定取前6列，逻辑更清晰。

内容的提问来源于stack exchange，提问作者smAC