I'm trying to create a command button that will send an email

[lukeskiiwalker]

Hello everyone,

Any help would be much appreciated. I'm trying to create a command button that will send emails from a certain range, say F2:F175. I would like this code to remove any duplicate emails in that range and not count any blank or 0 cells. Is this possible? below is what I have already started.

Thanks for any advice you can give me,
Rob

Private Sub CommandButton1_Click()
On Error GoTo ErrHandler


Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")


Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)

Dim myDataRng As Range


Set myDataRng = Range("f2:f175" & Cells(Rows.Count, "A").End(xlUp).Row)

Dim cell As Range
Dim iCnt As Integer
Dim sMail_ids As String


For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(1, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
End If
Next cell

Set myDataRng = Nothing

With objEmail
.To = sMail_ids
.Body = "Hello,"
.Display
End With


Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
'

End Sub

 

[LazyBug]

Hello!

It can be something like (didn't test):

Private Sub CommandButton1_Click()
Dim myDataRng As Range, r As Long, objOutlook As Object, objEmail As Object
On Error Resume Next
    Set myDataRng = Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
   
    Set objOutlook = CreateObject("Outlook.Application")
    If Err.Number <> 0 Then Set objOutlook = Nothing: Exit Sub
   
    For r = myDataRng.Rows.Count + 1 To 2 Step -1
        If Not IsEmpty(Cells(r, 6)) And Cells(r, 6).Value <> 0 Then
            Set objEmail = objOutlook.CreateItem(0)
                With objEmail
                    .To = Cells(r, 6).Value
                    .Body = "Hello,"
                    .Display
                End With
        End If
    Next r
   
    Set objEmail = Nothing: Set objOutlook = Nothing
End Sub

 

[lukeskiiwalker]

Thank you so much LazyBug for help on this problem I have been having. The coding works but what I need this button for is to send a Mass email to an entire group and not individual emails to each person. My group contains over 100 people 175 because of duplicate emails. Is there a way to do this?

 

[lukeskiiwalker]

Hello!

It can be something like (didn't test):

Private Sub CommandButton1_Click()
Dim myDataRng As Range, r As Long, objOutlook As Object, objEmail As Object
On Error Resume Next
    Set myDataRng = Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
  
    Set objOutlook = CreateObject("Outlook.Application")
    If Err.Number <> 0 Then Set objOutlook = Nothing: Exit Sub
  
    For r = myDataRng.Rows.Count + 1 To 2 Step -1
        If Not IsEmpty(Cells(r, 6)) And Cells(r, 6).Value <> 0 Then
            Set objEmail = objOutlook.CreateItem(0)
                With objEmail
                    .To = Cells(r, 6).Value
                    .Body = "Hello,"
                    .Display
                End With
        End If
    Next r
  
    Set objEmail = Nothing: Set objOutlook = Nothing
End Sub

Thank you so much LazyBug for help on this problem I have been having. The coding works but what I need this button for is to send a Mass email to an entire group and not individual emails to each person. My group contains over 100 people 175 because of duplicate emails. Is there a way to do this?

 

[LazyBug]

Maybe... (I have no way to check if it works)

Private Sub CommandButton1_Click()
Dim myDataRng As Range, r, objOutlook As Object, objEmail As Object
Dim d As Object, m As String
On Error Resume Next
    
    Set myDataRng = Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
    Set d = CreateObject("Scripting.Dictionary")

    For Each r In myDataRng
        If Not IsEmpty(r) And r.Value <> 0 Then d(r.Value) = r.Row
    Next r
    
    m = ""
    For Each r In d.keys
        m = m & r & ";"
    Next r
        
    Set objOutlook = CreateObject("Outlook.Application")
    If Err.Number <> 0 Then Set objOutlook = Nothing: Exit Sub
    
    Set objEmail = objOutlook.CreateItem(0)
        With objEmail
            .To = m
            .Body = "Hello,"
            .Display
        End With

    Set objEmail = Nothing: Set objOutlook = Nothing
End Sub

 

[lukeskiiwalker]

Maybe... (I have no way to check if it works)

Private Sub CommandButton1_Click()
Dim myDataRng As Range, r, objOutlook As Object, objEmail As Object
Dim d As Object, m As String
On Error Resume Next
   
    Set myDataRng = Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
    Set d = CreateObject("Scripting.Dictionary")

    For Each r In myDataRng
        If Not IsEmpty(r) And r.Value <> 0 Then d(r.Value) = r.Row
    Next r
   
    m = ""
    For Each r In d.keys
        m = m & r & ";"
    Next r
       
    Set objOutlook = CreateObject("Outlook.Application")
    If Err.Number <> 0 Then Set objOutlook = Nothing: Exit Sub
   
    Set objEmail = objOutlook.CreateItem(0)
        With objEmail
            .To = m
            .Body = "Hello,"
            .Display
        End With

    Set objEmail = Nothing: Set objOutlook = Nothing
End Sub

You knew this would work the whole time, didn't you? thank you, it works like a charm. I really appreciate you help.

 

[LazyBug]

You knew this would work the whole time, didn't you? thank you, it works like a charm. I really appreciate you help.

Nope, I really didn't know, but I'm glad it worked for you. Thanks for the feedback.