使用VBA从两个Excel工作表筛选数据生成邮件的问题

我有一个包含两个工作表（Sales和Transactions）的Excel文件：

1. Sales工作表 #

数据从第1行第1列开始，包含4列，每条数据对应一位员工，员工不重复，但主管（Supervisor）可重复。

2. Transactions工作表 #

数据从第1行第1列开始，包含5列，每条数据对应一周内的一笔交易，Sales表中的部分员工或主管可能不在此表中，部分员工和主管会重复出现。

需求 #

每周给Sales表中的每位主管发送邮件，仅包含其下属员工的两张表中的信息，行数不固定。例如给Joe的邮件需包含其下属的交易和销售数据，给Tom的邮件因无下属交易数据，仅显示销售数据。

遇到的问题 #

尝试使用Ron de Bruin的VBA示例但无法实现，具体问题：

• 无法筛选出对应主管的销售数据，始终获取全部销售数据；
• 需预先将Excel数据格式化为Table才能保证格式正确（此问题次要，核心需解决数据筛选问题）。

预先格式化为Table后的错误效果：邮件中包含所有主管的交易和销售数据，而非对应主管的下属数据。

当前使用的VBA代码 #

Sub email_multi_range()

Dim outapp As Object
Dim outmail As Object

Dim ash As Worksheet
Dim cws As Worksheet
Dim RCount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer

Dim rg1 As Range, rg2 As Range
Dim str1 As String, str2 As String

Set outapp = CreateObject("outlook.application")
Set outmail = outapp.CreateItem(0)

Set rg1 = locate(1, 1, "Transactions")
Set rg2 = locate(1, 1, "Sales") 

str1 = "<Body Style = front-size:12pt;font-family:Calibri>" & _
"Hello,<br>"
str2 = "<br>Thanks,<br>"


 'Set filter sheet, you can also use Sheets("MySheet")
    Set ash = Sheets("Sales")

    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = ash.Range("A1:L" & ash.Rows.Count)
    FieldNum = 2    'Filter column = B because the filter range start in column A

    'Add a worksheet for the unique list and copy the unique list in A1
    Set cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=cws.Range("A1"), _
            CriteriaRange:="", Unique:=True

    'Count of the unique values + the header cell
    RCount = Application.WorksheetFunction.CountA(cws.Columns(1))

    'If there are unique values start the loop
    If RCount >= 2 Then
        For Rnum = 2 To RCount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=cws.Cells(Rnum, 1).Value

            'If the unique value is a mail addres create a mail
            If cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

                With ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                  End With
                
                Set outmail = outapp.CreateItem(0)

                On Error Resume Next
                With outmail
   
    .To = cws.Cells(Rnum, 1).Value
    .Subject = "Low Docket Data"
    .Display
    .HTMLbody = str1 & RangetoHTML(rg1) & RangetoHTML(rg2) & str2 & .HTMLbody
    End With
    On Error GoTo 0
Set outmail = Nothing
  End If

            'Close AutoFilter
            ash.AutoFilterMode = False

        Next Rnum
    End If
Set outapp = Nothing

End Sub

Function locate(y1 As Long, x1 As Long, sh As String) As Range
Dim y2 As Long, x2 As Long
ThisWorkbook.Sheets(sh).Activate

y2 = WorksheetFunction.CountA(Range(Cells(y1, x1), Cells(y1, x1).End(xlDown))) + y1 - 1
x2 = WorksheetFunction.CountA(Range(Cells(y1, x1), Cells(y1, x1).End(xlToRight))) + x1 - 1

Set locate = Sheets(sh).Range(Cells(y1, x1), Cells(y2, x2))

End Function

核心问题分析 #

原代码的关键错误：

1. 直接使用locate函数获取整张表的原始数据范围，未对数据按当前主管筛选，导致邮件始终包含全部数据；
2. 筛选Sales表后获取了可见范围，但未实际使用，反而插入了未筛选的原始范围；
3. 缺少对Transactions表按主管筛选的逻辑。

修改后的代码 #

Sub email_multi_range()
    Dim outapp As Object, outmail As Object
    Dim ash As Worksheet, tsh As Worksheet, cws As Worksheet
    Dim RCount As Long, Rnum As Long
    Dim FilterRange As Range
    Dim currentEmail As String, currentSupervisor As String
    Dim salesRng As Range, transRng As Range
    Dim str1 As String, str2 As String
    
    '初始化Outlook对象
    Set outapp = CreateObject("outlook.application")
    str1 = "<Body style='font-size:12pt;font-family:Calibri;'>Hello,<br>"
    str2 = "<br>Thanks,<br>"
    
    '指定目标工作表
    Set ash = Sheets("Sales")
    Set tsh = Sheets("Transactions")
    
    '获取Sales表中唯一的主管邮箱列表
    Set FilterRange = ash.Range("A1:D" & ash.Cells(ash.Rows.Count, "A").End(xlUp).Row)
    Set cws = Worksheets.Add
    FilterRange.Columns(2).AdvancedFilter Action:=xlFilterCopy, _
                                          CopyToRange:=cws.Range("A1"), _
                                          Unique:=True
    RCount = Application.WorksheetFunction.CountA(cws.Columns(1))
    
    If RCount >= 2 Then
        For Rnum = 2 To RCount
            currentEmail = cws.Cells(Rnum, 1).Value
            '跳过非邮箱格式内容
            If currentEmail Like "?*@?*.?*" Then
                '获取当前邮箱对应的主管姓名
                currentSupervisor = ash.Cells(ash.Columns(2).Find(currentEmail).Row, "A").Value
                
                '筛选Sales表中当前主管的下属数据
                ash.Range("A1").AutoFilter Field:=1, Criteria1:=currentSupervisor
                On Error Resume Next
                Set salesRng = ash.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                
                '筛选Transactions表中当前主管的下属数据
                tsh.Range("A1").AutoFilter Field:=1, Criteria1:=currentSupervisor
                On Error Resume Next
                Set transRng = tsh.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                
                '创建并编辑邮件
                Set outmail = outapp.CreateItem(0)
                With outmail
                    .To = currentEmail
                    .Subject = "Team Sales & Transaction Data"
                    .HTMLBody = str1
                    '添加交易数据（有数据才显示）
                    If Not transRng Is Nothing Then
                        .HTMLBody = .HTMLBody & "<h3>Transaction Data</h3>" & RangetoHTML(transRng)
                    End If
                    '添加销售数据
                    .HTMLBody = .HTMLBody & "<h3>Sales Data</h3>" & RangetoHTML(salesRng) & str2
                    .Display '测试用，改为.Send可直接发送邮件
                End With
                
                '清理对象
                Set outmail = Nothing
                Set salesRng = Nothing
                Set transRng = Nothing
            End If
            
            '关闭自动筛选
            ash.AutoFilterMode = False
            tsh.AutoFilterMode = False
        Next Rnum
    End If
    
    '删除临时工作表
    Application.DisplayAlerts = False
    cws.Delete
    Application.DisplayAlerts = True
    
    Set outapp = Nothing
End Sub

Function RangetoHTML(rng As Range) As String
    '将Excel单元格范围转为HTML格式的核心函数
    Dim fso As Object, ts As Object
    Dim tempFile As String, tempWB As Workbook
    
    tempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    rng.Copy
    Set tempWB = Workbooks.Add(1)
    With tempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(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 tempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=tempFile, _
         Sheet:=tempWB.Sheets(1).Name, _
         Source:=tempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(tempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    
    tempWB.Close SaveChanges:=False
    Kill tempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set tempWB = Nothing
End Function

修改说明 #

1. 筛选逻辑修正：对Sales和Transactions表分别按主管姓名筛选，确保仅获取当前主管下属的数据；
2. 临时表自动清理：使用完存储唯一邮箱的临时工作表后自动删除，避免残留；
3. 邮件内容优化：根据是否存在交易数据决定是否显示交易板块，避免空内容；
4. 补充核心函数：添加原代码依赖的RangetoHTML函数，确保Excel范围能正确转为HTML格式插入邮件；
5. 简化范围定义：通过End(xlUp)获取数据最后一行，避免空行导致的范围错误，替代原locate函数。

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