Question

我有一个包含两个工作表的工作簿。 Sheet＆＃34;门票＆＃34;是一个列表，其中包括第一列中的manager userid和其他3列中的一些其他数据。 Sheet＆＃34; Email_List＆＃34;包含经理用户ID，电子邮件地址和名字。

我希望脚本使用userid来选择＆＃34; Tickets＆＃34;中的行。与＃34; Email_List＆＃34;中的每位经理相关并将该选择通过电子邮件发送给该经理。

选择部分似乎正在运行，向相关经理发送的电子邮件似乎正在发挥作用，而不仅仅是发送选择;整个＆＃34;门票＆＃34;表正在发送。

编辑：经过进一步调查，当所有匹配的用户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

你尝试过滤＆＃34;门票＆＃34;每个经理ID的单元格：

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

注意：您需要在＆＃34; Tickets＆＃34;

中插入标题行作为第一行

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

1 个答案: