VBA Sending email to addresses in column

[ScottWUK]

Hello Everyone,

First time posting on the board (even though I have been here a while I've never signed up until today!)

I wondered if someone could help me with (what I hope will be) a quick VBA query. I have a macro that is picking up email addresses from Column B so long as in Column C the field contains "Active". The VBA then creates an email for each email address. I would like the macro to create one email for all people who meet the criteria and their email addresses to be added to .bcc. Ideally this should look for an address in B and then stop once it gets to an empty row (but if that cant be done then I'm happy for any suggestions!)

Below is an example of my table starting from A7

[TABLE="width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Email Address[/TD]
[TD]Active/Inactive[/TD]
[/TR]
[TR]
[TD]User 1[/TD]
[TD]user1@madeup.co.uk[/TD]
[TD]Active[/TD]
[/TR]
[TR]
[TD]User 2[/TD]
[TD]user2@madeup.co.uk[/TD]
[TD]Inactive[/TD]
[/TR]
[TR]
[TD]User 3[/TD]
[TD]user3@madeup.co.uk[/TD]
[TD]Active[/TD]
[/TR]
</tbody>[/TABLE]


Here is my current macro:

Sub EmailActiveTaskManagers()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim ws As Worksheet
    


    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")


    On Error GoTo cleanup
    For Each cell In Column("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.row, "C").Value) = "active" Then


            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.value
                .BCC = " "
                .Subject = "IMPORTANT - FOR YOUR ACTION"
                .HTMLBody = "EMAIL TEXT"
                .Display  'Or use Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
        Next cell


cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Thank you in advance for your help!

 

[NdNoviceHlp]

Trial this...

Sub EmailActiveTaskManagers()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim ws As Worksheet

Dim Rng As Range, Lastrow As Integer
With Sheets("Sheet1")
    Lastrow = .Range("B" & .Rows.Count).End(xlUp).Row
End With
Set Rng = Sheets("Sheet1").Range("B7:B" & Lastrow)

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Rng
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "active" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
    .To = cell.Value
    .BCC = C.Text
    .Subject = "IMPORTANT - FOR YOUR ACTION"
    .HTMLBody = "EMAIL TEXT"
    .Display  'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

HTH. Dave

 

[ScottWUK]

Hello Dave,

Thanks for the speedy reply. Unfortunately, this still creates an email per person. I was looking for the VBA just to create one email and add all recipients to the .BCC in the email (sorry if I wasn't clear in my original post!)

Scott

 

[Legacy 421546]

Just gather all email addresses separated by a semicolon in a string. Set .bcc (or .to) to this string. Then send.

 

[Legacy 421546]

OR use this function:

'*******************************************************************
'* Add recipients, CC or BCC recipients to the email message
'* Recipients is a string with one or more email addresses,
'* each separated with a semicolon
'* Returns number of addresses added
'*
Private Function AddRecipients(Recipients As String, MAPIMailItem As Object, RecType As Integer) As Integer
  Dim OLRecipient As Object
  Dim TempArray() As String
  Dim Recipient As Variant  'For Each -> Variant
  Dim Emailaddr As String
  Dim Count As Integer

  Count = 0
  TempArray = Split(Recipients, ";")
  For Each Recipient In TempArray
    Emailaddr = Trim(Recipient)
    If Emailaddr <> "" Then
      Set OLRecipient = MAPIMailItem.Recipients.Add(Emailaddr)
      OLRecipient.Type = RecType
      Set OLRecipient = Nothing
      Count = Count + 1
    End If
  Next Recipient
  AddRecipients = Count
End Function

 

[ScottWUK]

Hey Johnny,

Thanks for this. I used the string idea and this is now working. Thanks for the advice!