vba - Excel VBA 为多个收件人、抄送和密件抄送撰写电子邮件

Question

我正在尝试创建一封发送给多人的电子邮件。
现在，我在一列中有电子邮件地址，右侧有“发送至”、“抄送”或“密件抄送”复选框。

Emails address: B3 - B13 (this list will expand, i may end up using lastrow)

"True/False" To: D3- D13

"True/False" CC: F3- F13

"True/False" BCC: H3- H13

Send if TRUE, skip if FALSE.

我确信这已经很简单了，但我已经看过了，但我被卡住了。

感谢您的任何回复。

Answer 1

这是一个应该做你想做的宏，当然可以根据你的具体需求进行调整，因为问题很模糊......

请参阅评论以获取解释。

Sub sendEmail()

' Set up outlook objects for emailing

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

' Body text for the email
Dim strbody As String
strbody = "This text in the body of your email"

' Strings to contain the email addresses
Dim sendTo As String
sendTo = ""
Dim sendCC As String
sendCC = ""
Dim sendBCC As String
sendBCC = ""

' The cell containing the email address (loop variable)
Dim emailCell As Range

With ActiveSheet

    ' Cycle through email addresses, from B3 to one before next blank cell in column
    For Each emailCell In .Range("B3", .Range("B3").End(xlDown))

        ' Check each TRUE/FALSE column in same row, add email addresses accordingly

        If .Cells(emailCell.Row, "D").Text = "TRUE" Then

            sendTo = sendTo & "; " & emailCell.Text

        End If

        If .Cells(emailCell.Row, "F").Text = "TRUE" Then

            sendCC = sendCC & "; " & emailCell.Text

        End If

        If .Cells(emailCell.Row, "H").Text = "TRUE" Then

            sendBCC = sendBCC & "; " & emailCell.Text

        End If

    Next emailCell

End With

' Generate email in outlook objects defined above
On Error Resume Next
With OutMail
    .To = sendTo
    .CC = sendCC
    .BCC = sendBCC
    .Subject = "Subject Message Here"
    .HTMLBody = strbody
    .Display 
    ' If you don't want to display the email before sending it, 
    ' simply use .Send instead of .Display
End With
On Error GoTo 0

End Sub