Exporting data of selected name and email the data to the mail ID.

[jlokesh16]

I have a master sheet (Sheet1) whose sample data is as below.

Book1
	A	B	C	D	E	F	G	H	I	J	K
1	Call ID	Call Link	Category	Score	Score	Scoring Agent	Assessment	QA	Error Type	Revised	Comment
2	7328001	https:\\www.google.com	leaseterm	6-12Month	Did Not Discuss	John	10th August	Tina	S1	Quality Correct	All Ok
3	7328001	https:\\www.google.com	leaseterm	6-12Month	Did Not Discuss	Tony	10th August	Tina	S2	Quality Correct	All Ok
4	7328001	https:\\www.google.com	leaseterm	6-12Month	Did Not Discuss	John	10th August	Tina	S3	Quality Correct	All Ok
Sheet1

I have sheet 2 where below data is filled in it.

Book1
	A	B
1	Name	email
2	John	john123@gmail.com
3	Mack	mack123@gmail.com
Sheet2

I want a macro where if i run it, data from sheet 1 (all data) of a user will be emailed to that specific user only.
EG: Data of John will be emailed to john123@gmail.com (data will consist 11 columns and 2 rows as John is repeated twice).
Hence john will get data from Sheet1 (11 columns & 2 rows) via email to his mail id.
After john, macro will then check the second row and email the available data of tony to his email ID.
Hence the loop will continue until there is data in col F.

 

[paulxmw]

Hi

What happens if there are two johns, how will the code know who to email out, I have a sheet already which does what you want but the email must be on the same sheet in the example below which runs from a CMD button it takes the email from the sheet in column B Which could be changed to A, loops through the page then creates 1 email to each person but if the email address appears more than once the lines are looped together, you should include headers on the sheet as these will be picked up and inserted into the email.

Dim OutApp As Object
    Dim OutMail As Object
    Dim lRow As Integer
    Dim i As Integer
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer
    Dim sBody As String
    
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
     'Email message body
    StrBody = "A little text to read"
              
  sBody = "Some text to read"

    'Set filter sheet, you can also use Sheets("Email text")
    Set Ash = ActiveSheet

    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count) 'You can amend the columns sent here
    FieldNum = 2    'Filter column = B because the filter range start in column A

    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=True

    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value


              
            'If the unique value is a mail address create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                    
                End With

Set OutMail = OutApp.CreateItem(0)

                On Error Resume Next


                With OutMail
                    .SentOnBehalfOfName = "me@gmail.com"
                    .To = Cws.Cells(Rnum, 1).Value
                    .Subject = "some text in subject"
                    .Body = StrBody & sBody 'changed
                    .Display ' or Send
                    
                End With
              
                On Error GoTo 0

                Set OutMail = Nothing
            End If

            'Close AutoFilter
            Ash.AutoFilterMode = False
            

        Next Rnum
    End If


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

 
    On Error GoTo 0



cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
MsgBox ("All emails have now been sent")

End Sub

Hope this helps

 

[jlokesh16]

Getting error " Invalid outside procedure".
I have entered all the email ID's in col B, and the first table where i have master data, the call ID has now become col C and so on.
Also the names are in format "First name Last name", and even john name repeats, the email id will not be same for both Johns.

 

[paulxmw]

Hi

Sorry this runs from the email been in column A not B but like i said all the data must be on the sheet it wont link one to another also are you running it from a command button

Paulxmw

 

[jlokesh16]

Yes, emails list is in Col A and the master data table starts from col B, but still not working, getting the same error.

 

[paulxmw]

HMM
I have used this code for years, with no issues, have you changed anything, as i copied the code from my post put on a blank sheet with button and it ran fine

Paulxmw