Outlook收件人根据条件键入

Posted 2021-04-05

我正在尝试选择具有固定范围C6：C11的收件人电子邮件地址（C列），基于（D列）固定范围中定义的标准（MainR或CC）以及D6：D11，然后将其添加作为主要收件人或抄送收件人。

我的代码适用于一个固定范围（C列）C6：C11。对于该列中的每个单元格。如果电子邮件地址的字符串中包含“@”，它会将单元格选为收件人。

示例如下：

Set xRg = Sheet1.Range("C6:C11")
Set xOTApp = CreateObject("Outlook.Application")
For Each xCell In xRg
    If xCell.Value Like "*@*" Then
        If xEmailAddr = "" Then
            xEmailAddr = xCell.Value
        Else
            xEmailAddr = xEmailAddr & ";" & xCell.Value
        End If
    End If
Next

我正在寻找切换当前范围（C6：C11），其范围包含我的关键字（D6：D11）。对于该列中的每个MainR或CC，宏应使用相邻的电子邮件地址（C C6：C11列）。

完整代码：

Sub Mail_small_Text_Outlook()

'My variables

Dim xOutApp As Object
Dim xOutMail As Object
Dim xOTApp As Object
Dim xMItem As Object

Dim xMailBody As String
Dim xEmailAddr As String
Dim zEmailAddr As String

Dim xCell As Range
Dim zCell As Range
Dim xRg As Range
Dim zRg As Range


Dim ws As Worksheet
On Error Resume Next

Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)

'Email body

xMailBody = "" & vbNewLine


' Main recipient code

Set xRg = Sheet1.Range("C6:C11")

Set xOTApp = CreateObject("Outlook.Application")
For Each xCell In xRg
    If xCell.Value Like "*@*" Then
        If xEmailAddr = "" Then
            xEmailAddr = xCell.Value
        Else
            xEmailAddr = xEmailAddr & ";" & xCell.Value
        End If
    End If
Next

' CC recipient code

Set zRg = Sheet1.Range("C7:c11")
For Each zCell In zRg
    If xCell.Value Like "*@*" Then
        If zEmailAddr = "" Then
            zEmailAddr = zCell.Value
        Else
            zEmailAddr = zEmailAddr & ";" & zCell.Value
        End If
    End If
Next

'Email Code

Set xMItem = xOTApp.CreateItem(0)
With xMItem
    .To = xEmailAddr
    .CC = zEmailAddr
    .BCC = ""
    .Subject = ""
    .Body = xMailBody
    .Display   'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

答案

您应该能够通过在单个FOR循环中组合您的地址集合来实现这一目标：

For Each xCell In xRg
    If xCell.Value Like "*@*" Then
        If LCase(Trim(Sheet1.Range("D"& xCell.Row).Value)) = "mainr" Then
            If xEmailAddr = "" Then
                xEmailAddr = xCell.Value
            Else
                xEmailAddr = xEmailAddr & ";" & xCell.Value
            End If
        ElseIf LCase(Trim(Sheet1.Range("D"& xCell.Row).Value)) = "cc" Then
            If zEmailAddr = "" Then
                zEmailAddr = xCell.Value
            Else
                zEmailAddr = zEmailAddr & ";" & xCell.Value
            End If
        Else
            <your error handling here for unexpected value in D range>
        End If
    End If
Next

作为旁注，我会从函数中删除On Error Resume Next，因为它往往会隐藏在调试时不利的错误

另一答案

你可以使用AutoFilter()：

Sub Mail_small_Text_Outlook()

    ... your code

    Dim xRg As Range
    Dim xEmailAddr As String
    Dim zEmailAddr As String

    Set xRg = Sheet1.Range("C5:C11") ' include headers for autofilter to work

    With xRg.Resize(, 3) 'include email addresses and recipient columns
        .Sort key1:=.Cells(1, 3), key2:=.Cells(1, 2), header:=xlYes 'sort on recipients and email addresses to make sure you'll have adjacent filtered cells
        xEmailAddr = GetEmailAddresses(.Cells, "MainR") 'get "Main Recipient" addresses
        zEmailAddr = GetEmailAddresses(.Cells, "cc") 'get "cc" addresses
    End With

    ...
    rest of your code


End Sub

Function GetEmailAddresses(rng As Range, recipient As String) As String
    With rng
        .AutoFilter Field:=2, Criteria1:="*@*" ' filter referenced cells on 1st column with "0" content
        .AutoFilter Field:=3, Criteria1:=recipient ' filter referenced cells on 2nd column with "4000" content
        Select Case Application.WorksheetFunction.Subtotal(103, .Columns(3))
            Case 2
                GetEmailAddresses = .Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible).value
            Case Is > 2
                GetEmailAddresses = Join(Application.Transpose(.Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible).value), ";")
        End Select
        .Parent.AutoFilterMode = False
    End With
End Function