VBA 通过电子邮件发送选择失败

Question

我有一个包含两个工作表的工作簿。工作表“Tickets”是一个列表，其中包括第一列中的经理用户 ID 和其他 3 列中的一些其他数据。工作表“Email_List”包含经理用户 ID、电子邮件地址和名字。

我希望脚本使用用户 ID 在“工单”中选择与“Email_List”中的每个经理相关的行，并将该选择通过电子邮件发送给该经理。

选择部分似乎工作，给相关经理的电子邮件似乎工作，但不仅仅是发送选择；正在发送整个“Tickets”表。

编辑：经过进一步调查，当所有匹配的用户 ID 都位于单个连续行块中时，它可以工作。因此，一种解决方法是在运行此脚本之前对 UserID 列进行排序。

Sub SendSelection()

Dim Sendrng As Range
Dim i As Integer
Dim rCell As Range
Dim rRng As Range
Dim lRow As Long
Dim sht As Worksheet
Dim StartCell As Range
Dim rRng2 As Range

'Set up the range to base the selection on
Set sht = Sheets("Tickets")
Set StartCell = Range("A1")

lRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row

Set rRng2 = sht.Range("A1:A" & lRow)

i = 1
'set it to loop through each the user ids
Do While Sheets("Email_List").Cells(i, 1).Value <> ""
'look through cells in first column of data in "Tickets"
For Each rCell In rRng2
    'If the userids match, then...
    If rCell.Value = Sheets("Email_List").Cells(i, 1).Value Then
        'set initial rRng to the first matched cell and the rest of the row
        If rRng Is Nothing Then
                Set rRng = Range(rCell, rCell.Offset(0, 3))
            'then add subsequent matched cells/rows to rRng
            Else
                Set rRng = Application.Union(rRng, Range(rCell, rCell.Offset(0, 3)))
        End If
    End If
Next
'select the range of matched data
rRng.Select
'set the selection as the range of data to be sent
Set Sendrng = Selection

'Create the mail and send it
With Sendrng

    ActiveWorkbook.EnvelopeVisible = True
    With .Parent.MailEnvelope

        .Introduction = "TEST ONLY"

        With .Item
            'get email address from "Email_List"
            .To = Sheets("Email_List").Cells(i, 2).Value
            .CC = ""
            .BCC = ""
            .Subject = "**TEST**"
            .Send
        End With

    End With

End With
Set rRng = Nothing
i = i + 1

Loop

End Sub

Answer 1

您尝试按每个经理 ID 过滤“Tickets”单元格：

Option Explicit

Sub SendMails()
    Dim IDRng As Range, IDCell As Range

    With Worksheets("Email_List")
        Set IDRng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
    End With

    For Each IDCell In IDRng
        With Worksheets("Tickets")
            With .Range("D1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
                .AutoFilter field:=1, Criteria1:=IDCell.Value
                If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any IDCell has been filtered
                    SendSelection .Offset(1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible), IDCell
                End If
            End With
        End With
    Next IDCell
End Sub

Sub SendSelection(rngToSend As Range, IDCell As Range)
    Application.DisplayAlerts = False
    With rngToSend

        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope
            .Introduction = "TEST ONLY"
            With .Item
                'get email address from "Email_List"
                .To = IDCell.Offset(, 1).Value
                .CC = ""
                .BCC = ""
                .Subject = "**TEST**"
                .Send
            End With
        End With
    End With
    Application.DisplayAlerts = True
End Sub

注意：您需要在“Tickets”中插入标题行作为第一行