Auto mail with filter Range

[Nabeel]

Hello All
I have attached the sheet already one code is under it,
I need some modification that to auto mail with some data!
Frist auto filter to column H then paste that table into outlook body,
Auto pick email address from column I (after filter change)
I want to write in mail body that,
Dear AA1(it will take from column H.
“Please share FOC approval of below missdn for auditors”
Regards
Nabeel


Nabeel

[HansV]

That is quite a complex request. I will look at it, but it'll take time.

[Nabeel]

no issue sir, just one request please remove my attachment from opening post after looking off as e-mail addresses are real. i will be greatful!

Nabeel

[HansV]

You should always replace "real" information with made-up data in files that you attach to a post!

[HansV]

I haven't forgotten you but I have very little time this weekend. Sorry!

[Nabeel]

No issue sir, happy weekend!

Nabeel

[HansV]

Here is a macro. Please see the comments in the text.

Code: Select all

Sub Mail_Selection_Range_Outlook_Body()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim r As Long
    Dim m As Long
    Dim CAM As String
    Dim Email As String
    Dim doc As Object
    Dim rng2 As Object

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

    Range("M1").Value = Range("G1").Value
    Range("M2").Value = "NO"
    
    Range("O1").Value = Range("H1").Value

    Range("Q1").Value = Range("G1").Value
    Range("Q2").Value = "NO"
    Range("R1").Value = Range("H1").Value

    Range("A1").CurrentRegion.AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=Range("M1:M2"), _
        CopyToRange:=Range("O1"), _
        Unique:=True

    m = Range("O" & Rows.Count).End(xlUp).Row
    ' For testing purposes, this version produces only two messages.
    ' After testing, change 3 to m
    For r = 2 To 3 ' m
        CAM = Range("O" & r).Value
        Email = Application.VLookup(CAM, Range("H:I"), 2, False)
        If Email <> "0" Then
            Range("R2").Value = CAM
            Range("A1").CurrentRegion.AdvancedFilter _
                Action:=xlFilterInPlace, _
                CriteriaRange:=Range("Q1:R2")
            Set rng = Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .Display
                .To = Email
                .CC = "BSD-Lead Management Team <BSD-LeadManagementTeam@jazz.com.pk>"
                .Subject = "Approval Required"
                Set doc = OutApp.ActiveInspector.WordEditor
                doc.Content.Delete
                doc.Content.InsertAfter "Dear " & CAM & ","
                doc.Content.InsertParagraphAfter
                doc.Content.InsertParagraphAfter
                ' Please check the spelling!
                doc.Content.InsertAfter "Please share FOC approval of below missdn for auditors"
                doc.Content.InsertParagraphAfter
                doc.Content.InsertParagraphAfter
                rng.Copy
                Set rng2 = doc.Content
                rng2.collapse Direction:=0
                rng2.Paste
                doc.Content.InsertParagraphAfter
                doc.Content.InsertAfter "Regards,"
                doc.Content.InsertParagraphAfter
                doc.Content.InsertAfter "Nabeel"
            End With
        End If
    Next r

    Application.CutCopyMode = False
    ActiveSheet.ShowAllData
    Application.ScreenUpdating = True

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

[Nabeel]

Hi sir

thnx for your code and kind help, sir its created only 2 mails and stops!

nabeel

[HansV]

Yes - that's why I mentioned "Please see the comments in the text.":

Code: Select all

    ' For testing purposes, this version produces only two messages.
    ' After testing, change 3 to m
    For r = 2 To 3 ' m

If the first two messages look OK, change the line

Code: Select all

    For r = 2 To 3

to

Code: Select all

    For r = 2 To m

[Nabeel]

thanks you so much sir,this is brilliant

" you are the best and beated the best sir"

Nabeel

[HansV]

Thank you for your kind words!