Copy cells by lookup from email (To)

P

Patriot2879

Well-known Member
Joined
Feb 1, 2018
Messages
1,227
Office Version
  1. 2010
Platform
  1. Windows
Hi Hope you can help me please i have the code below where it sends seperate bulk emails, but i want it to lookup the 'To' email address and find it in cell F then copy from G to L and paste in the body.
VBA Code: 
Private Sub CommandButton1_Click()

Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
        With Mail_Object.CreateItem(o)
            .Subject = Range("D2").Value
            .To = Range("B" & i).Value
            .CC = Range("C" & i).Value
            .Body = Range("E2").Value
            '.Send
            .display 'disable display and enable send to send automatically
    End With
Next i
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
I have tried something like the code below but this doesnt work, where i want it to look at the 'To' address in the email and find this in sheet1 under row F and paste the range next to the name found G to L -
VBA Code: 
Private Sub CommandButton1_Click()

Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "B").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
        With Mail_Object.CreateItem(o)
            .Subject = Range("D2").Value
            .To = Range("B" & i).Value
            .CC = Range("C" & i).Value
            .Body = Range("E2").Value
            '.Send
            .display 'disable display and enable send to send automatically
    End With
Next i
        MsgBox "E-mail successfully sent", 64
        Application.DisplayAlerts = False
Set Mail_Object = Nothing

   Dim Fnd As Range
  
   Set Fnd = Sheets("Sheet1").Range("F:F").Find(MailTo.Value, , , xlWhole, , , False, , False)
   If Not Fnd Is Nothing Then
      Range("G:L").Value = Fnd.Offset(, 1).Value


   End If
End Sub
 
Upvote 0
Hi i have sort of got the code below to work but i cant get it to copy the data i want. i want it copy the range from I1:N1, but i have changed it in the code and it didnt work. the code below sends an individual email with the date and area they are working, by finding the range. but i am really stuck now as i dont understand why it cant go from I2 : N2 i have added a pic, please can you help me?
VBA Code: 
Private Sub CommandButton1_Click()

'Set email address as range for first loop to run down
Set Rng = Range(Range("E2"), Range("E" & Rows.Count).End(xlUp))

'Get a row count to clear column H at the end
x = Rng.Rows.Count

PgStart = "<html><body>"

'Create the html table and header from the first row
tableHdr = "<table border=1><tr><th>" & Range("A1").Value & "</th>" _
& "<th>" & Range("B1").Value & "</th>" _
& "<th>" & Range("C1").Value & "</th>" _
& "<th>" & Range("D1").Value & "</th>" _
& "<th>" & Range("E1").Value & "</th>" _
            & "<th>" & Range("F1").Value & "</th>" _

'Check to see if column G = 'yes' and skip mail if it does
For Each cell In Rng
If cell.Value <> "" Then
    If Not cell.Offset(0, 2).Value = "yes" Then

      
    NmeRow = cell.Row

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

    MailTo = cell.Value 'column E
mailcc = cell.Offset(0, -3).Value
MailSubject = "Rota"

'Create MailBody table row for first row
MailBody = "<tr>" _
& "<td>" & cell.Offset(0, -4).Value & "</td>" _
& "<td>" & cell.Offset(0, -3).Value & "</td>" _
& "<td>" & cell.Offset(0, -2).Value & "</td>" _
& "<td>" & cell.Offset(0, -1).Value & "</td>" _
& "<td>" & cell.Value & "</td>" _
& "<td>" & cell.Offset(0, 1).Value & "</td>" _
            & "</tr>"

'Second loop checks the email addresses of all cells following the current cell in the first loop.
'Yes will be appended on any duplicate finds and another row added to the mailbody table
    For Each dwn In Rng.Offset(NmeRow - 1, 0)



    If dwn.Value = cell.Value Then

'Create additional table row for each extra row found
AddRow = "<tr>" _
& "<td>" & dwn.Offset(0, -4).Value & "</td>" _
& "<td>" & dwn.Offset(0, -3).Value & "</td>" _
& "<td>" & dwn.Offset(0, -2).Value & "</td>" _
& "<td>" & dwn.Offset(0, -1).Value & "</td>" _
& "<td>" & dwn.Value & "</td>" _
& "<td>" & dwn.Offset(0, 1).Value & "</td>" _
            & "</tr>"

    dwn.Offset(0, 2).Value = "yes"
    MailBody = MailBody & AddRow  'column A

    End If
' Clear additional table row variable ready for next
AddRow = ""
Next

MsgStr = "<p>To " & cell.Offset(0, 1).Value & "<br><br>" _
& "Please see below your rota.</p><br>"

With OutMail
.To = MailTo
.CC = mailcc
.Subject = MailSubject
.HTMLBody = PgStart & MsgStr & tableHdr & MailBody & "</table></body></html>"
.Display
'send
End With

cell.Offset(0, 2).Value = "yes"

End If
End If


MailTo = ""
MailSubject = ""
MailBody = ""
Next

'Clear 'yes' from all appended cells in column H
Range("G2:G" & x + 1).ClearContents
End Sub
 

Attachments

  • Untitled.jpg
    Untitled.jpg
    224 KB · Views: 4
Upvote 0
Hi i have sort of got the code below to work but i cant get it to copy the data i want. i want it copy the range from I1:N1, but i have changed it in the code and it didnt work. the code below sends an individual email with the date and area they are working, by finding the range. but i am really stuck now as i dont understand why it cant go from I2 : N2 i have added a pic, please can you help me?
VBA Code: 
Private Sub CommandButton1_Click()

'Set email address as range for first loop to run down
Set Rng = Range(Range("E2"), Range("E" & Rows.Count).End(xlUp))

'Get a row count to clear column H at the end
x = Rng.Rows.Count

PgStart = "<html><body>"

'Create the html table and header from the first row
tableHdr = "<table border=1><tr><th>" & Range("A1").Value & "</th>" _
& "<th>" & Range("B1").Value & "</th>" _
& "<th>" & Range("C1").Value & "</th>" _
& "<th>" & Range("D1").Value & "</th>" _
& "<th>" & Range("E1").Value & "</th>" _
            & "<th>" & Range("F1").Value & "</th>" _

'Check to see if column G = 'yes' and skip mail if it does
For Each cell In Rng
If cell.Value <> "" Then
    If Not cell.Offset(0, 2).Value = "yes" Then

      
    NmeRow = cell.Row

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

    MailTo = cell.Value 'column E
mailcc = cell.Offset(0, -3).Value
MailSubject = "Rota"

'Create MailBody table row for first row
MailBody = "<tr>" _
& "<td>" & cell.Offset(0, -4).Value & "</td>" _
& "<td>" & cell.Offset(0, -3).Value & "</td>" _
& "<td>" & cell.Offset(0, -2).Value & "</td>" _
& "<td>" & cell.Offset(0, -1).Value & "</td>" _
& "<td>" & cell.Value & "</td>" _
& "<td>" & cell.Offset(0, 1).Value & "</td>" _
            & "</tr>"

'Second loop checks the email addresses of all cells following the current cell in the first loop.
'Yes will be appended on any duplicate finds and another row added to the mailbody table
    For Each dwn In Rng.Offset(NmeRow - 1, 0)



    If dwn.Value = cell.Value Then

'Create additional table row for each extra row found
AddRow = "<tr>" _
& "<td>" & dwn.Offset(0, -4).Value & "</td>" _
& "<td>" & dwn.Offset(0, -3).Value & "</td>" _
& "<td>" & dwn.Offset(0, -2).Value & "</td>" _
& "<td>" & dwn.Offset(0, -1).Value & "</td>" _
& "<td>" & dwn.Value & "</td>" _
& "<td>" & dwn.Offset(0, 1).Value & "</td>" _
            & "</tr>"

    dwn.Offset(0, 2).Value = "yes"
    MailBody = MailBody & AddRow  'column A

    End If
' Clear additional table row variable ready for next
AddRow = ""
Next

MsgStr = "<p>To " & cell.Offset(0, 1).Value & "<br><br>" _
& "Please see below your rota.</p><br>"

With OutMail
.To = MailTo
.CC = mailcc
.Subject = MailSubject
.HTMLBody = PgStart & MsgStr & tableHdr & MailBody & "</table></body></html>"
.Display
'send
End With

cell.Offset(0, 2).Value = "yes"

End If
End If


MailTo = ""
MailSubject = ""
MailBody = ""
Next

'Clear 'yes' from all appended cells in column H
Range("G2:G" & x + 1).ClearContents
End Sub
 

Attachments

  • Untitled.jpg
    Untitled.jpg
    224 KB · Views: 2
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Send email via outlook from specified account
Replies
1
Views
1K
mustafaqusay
M
T
  • Question
VBA- Copy & Paste Range into Outlook as a Picture
Replies
1
Views
121
Domenic
D
T
  • Solved
Sending daily emails based on criteria, with email body corresponding to parallel cell which holds email address(es)
Replies
1
Views
774
twinwings
T
The Ruff Report
  • Question
Help adjusting Macro to email multiple cc addresses
Replies
1
Views
381
The Ruff Report
The Ruff Report
A
  • Question
Email automation - hyperlink filepath
Replies
1
Views
120
NateSC
NateSC

Forum statistics

Threads
1,214,992
Messages
6,122,631
Members
449,095
Latest member
bsb1122

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top