How to send email based on Filtered Row while using Macro

[AmirFirdaus9509]

Hi All ,
I need your expertise in how to send Email based on a table. I have a table that contain user name , email , cc , subject and location.
I would like to filtered out location and expect the macro to loop in the filtered row instead of capturing all row when i pressed the "Send Email" button . As shown in the image below , I would like it to send out detail on Row 5 and 10 where I would expect only 2 email draft. But the macro is capturing all row from 2 to 10 and giving out 9 Email Draft.

Below i have attached a macro that i am using .

Sub send_mass_email()
Dim i As Integer
Dim name, email, body, subject, copy, place, business As String
Dim OutApp As Object
Dim OutMail As Object
Dim cel As Range



body = ActiveSheet.TextBoxes("TextBox 1").Text

i = 2
'Loop down name column starting at row 2 column 1




Do While Cells(i, 1).Value <> ""



name = Split(Cells(i, 1).Value, " ")(0) 'extract first name
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
business = Cells(i, 5).Value
place = Cells(i, 6).Value


'replace place holders
body = Replace(body, "C1", name)
body = Replace(body, "C5", business)
body = Replace(body, "C6", place)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.body = body
'.Attachments.Add ("") 'You can add files here
.display
'.Send


End With

'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text

i = i + 1


Loop

Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Email(s) Created!"

End Sub


Thank you very much

 

[mumps]

Try:

Sub send_mass_email()
    Dim i As Integer, cel As Range
    Dim name As String, email As String, body As String, subject As String, copy As String, place As String, business As String
    Dim OutApp As Object, OutMail As Object
    body = ActiveSheet.TextBoxes("TextBox 1").Text
    Set OutApp = CreateObject("Outlook.Application")
    For Each cel In Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        name = Split(cel, " ")(0) 'extract first name
        email = cel.Offset(, 1).Value
        subject = cel.Offset(, 2).Value
        copy = cel.Offset(, 3).Value
        business = cel.Offset(, 4).Value
        place = cel.Offset(, 5).Value
        'replace place holders
        body = Replace(body, "C1", name)
        body = Replace(body, "C5", business)
        body = Replace(body, "C6", place)
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .to = email
            .cc = copy
            .subject = subject
            .body = body
            '.Attachments.Add ("") 'You can add files here
            .display
            '.Send
        End With
    Next cel
    MsgBox "Email(s) Created!"
End Sub

 

[AmirFirdaus9509]

Try:

Sub send_mass_email()
    Dim i As Integer, cel As Range
    Dim name As String, email As String, body As String, subject As String, copy As String, place As String, business As String
    Dim OutApp As Object, OutMail As Object
    body = ActiveSheet.TextBoxes("TextBox 1").Text
    Set OutApp = CreateObject("Outlook.Application")
    For Each cel In Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        name = Split(cel, " ")(0) 'extract first name
        email = cel.Offset(, 1).Value
        subject = cel.Offset(, 2).Value
        copy = cel.Offset(, 3).Value
        business = cel.Offset(, 4).Value
        place = cel.Offset(, 5).Value
        'replace place holders
        body = Replace(body, "C1", name)
        body = Replace(body, "C5", business)
        body = Replace(body, "C6", place)
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .to = email
            .cc = copy
            .subject = subject
            .body = body
            '.Attachments.Add ("") 'You can add files here
            .display
            '.Send
        End With
    Next cel
    MsgBox "Email(s) Created!"
End Sub

Hi Mumps , thank you for you reply ,
I have run and your code work wonderfully except there is an error on the " out of subscript range " whenever i filter an it happen that the first row is the only filtered "Row 2" instead of giving 1 email draft it gives out 5

Thank you in advance

 

[mumps]

That is strange because the macro loops through the visible cells only and if row 2 is the only one visible, it should produce one email. It is hard to work with a picture like the one you posted in your first post. Could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here (de-sensitized if necessary).

 

[AmirFirdaus9509]

That is strange because the macro loops through the visible cells only and if row 2 is the only one visible, it should produce one email. It is hard to work with a picture like the one you posted in your first post. Could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here (de-sensitized if necessary).

Hi Mumps , thanks for the reply
Apologize for the delay on my reply , i managed to update the macro now it is working perfectly

Thank you very much!

 

[mumps]

You are very welcome.