Hi,
It sounds like you have the VBA to form the e-mail but are just having an issuing in looping through and creating the '.Body' part of the e-mail from multiple cells.
The code below loops through each row in my mocked up data and forms it in to one string called MailBody. This comprises of the greeting, persons name etc through to the sign off name. The vbCr you see is just adding the carriage return to format it with a row between lines.
The part MyName in my example takes my system name and puts my surname last and forename first as they are flipped in my Excel setup. I use this at the end of my string MailBody to add in the senders name.
For the e-mail address I have used SendTo and capture this from the data to use in the '.To' part of the e-mail,
VBA Code:
Sub EmailBody()
Dim SendTo As String
Dim Myname As String
Dim MailBody As String
Myname = Application.UserName
Myname = Right(Myname, Len(Myname) - InStr(Myname, " ")) & " " & Left(Myname, InStr(Myname, ", ") - 1) ' ** Sorts name in to first name first and then surname **
For Each i In Range("A2:A4")
'** creates the text to go in to the e-mail **
MailBody = i.Value & " " & i.Offset(0, 1) & vbCr & vbCr & i.Offset(0, 2) & vbCr & vbCr & i.Offset(0, 3) & vbCr & vbCr & i.Offset(0, 4) & vbCr & vbCr & Myname
SendTo = i.Offset(0, 5).Value
MsgBox MailBody & vbCr & vbCr & SendTo '** remove this as it is only there for proofing purposes **
'** Your e-mail code here with .Body = EmailBody, rough example below but not he full code.
' With OutMail
' .To = SendTo
' .BCC = ""
' .Subject = "Title of e-mail"
' .Body = EmailBody
' .Display
' End With
Next i
End Sub
You woud need to add in the code you have for the e-mail where indicated above and type EmailBody for the 'Body.' part in your code and SendTo for the '.To' part.
The popup is what the above generates for row 2 in my data...
View attachment 40023
Steven
Hi Steven,
Thanks for the previous help.
I took the code you have above and slotted it into the code I had. It manages to produce the string of emails, however it puts the info from the top line into every single email, not splitting the info into separate emails.
I have included a mini sheet with my data, and the VBA code I am using underneath.
Any ideas?
Book1 with macros.xlsm |
---|
|
---|
| A | B | C | D | | | | | | | | L |
---|
1 | Hospital Number | Exam Date | Exam | Radiographer | | | | | | | | Reporting Rad checking image |
---|
2 | R001 | 5/13/21 | Ankle | James Hoare | | | | | | | | James Hoare |
---|
3 | R002 | 5/13/21 | Pelvis | Harry Smyth | | | | | | | | Anna O'Brien |
---|
4 | R003 | 5/13/21 | Foot | James Hoare | | | | | | | | Steph Patts |
---|
|
---|
\
Sub ImagesForQaEmails()
Application.ScreenUpdating = False
ThisWorkbook.Activate
'Creating references to Application and MailItem Objects of Outlook
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
'Creating variable to hold values of different items of mail
Dim sendTo, MailBody As String
Dim lstRow As Long
ThisWorkbook.Sheets("Sheet1").Activate
'Getting last row of containing email id in column 3.
lstRow = Cells(Rows.Count, 5).End(xlUp).Row
Dim rng As Range
Set rng = Range("E2:E" & lstRow)
'initializing outlook object to access its features
Set outApp = New Outlook.Application
On Error GoTo cleanup 'to handle any error during creation of object.
For Each i In Range("A2:A100")
MailBody = "Dear " & i.Offset(0, 5) & "," & vbCr & vbCr & i.Offset(0, 6) & vbCr & vbCr & i.Offset(0, 7) & vbCr & vbCr & i.Offset(0, 8) & vbCr & vbCr & "Hospital Number: " & i.Value & vbCr & "Exam Date: " & i.Offset(0, 1) & vbCr & "Exam: " & i.Offset(0, 2) & vbCr & vbCr & "Kind regards," & vbCr & vbCr & i.Offset(0, 11) & vbCr & i.Offset(0, 9) & vbCr & i.Offset(0, 10)
For Each cell In rng
sendTo = Range(cell.Address).Offset(0, 0).Value2
subj = "Images for QA"
msg = MailBody
On Error Resume Next 'to hand any error during creation of below object
Set outMail = outApp.CreateItem(0)
'Writing and sending mail in new mail
With outMail
.To = sendTo
.Body = msg
.Subject = subj
.Display
End With
On Error GoTo 0 'To clean any error captured earlier
Set outMail = Nothing 'nullifying outmail object for next mail
Next cell 'loop ends
cleanup: 'freeing all objects created
Set outApp = Nothing
Application.ScreenUpdating = True
Application.ScreenUpdating = True
Next i
End Sub