VBA creating draft emails from addresses in excel
 

Hi guys,

I was hoping to pick your brains with a vba issue I am having.

On the attachment, column A has email addresses and in column B, has a list of names.

In another words, column A would have the managers email addresses and column B would have those managers employees names.

Basically, the employees in column B are receiving a payment but need the managers in column A, to confirm that there employees should be getting it.

I need VBA to look at an email address, for example, , create a draft email (see current VBA coding below which has the sentences) but I need the names in column B (Homer, Lisa, Marge, Maggie, Bart, Ned
Smithers) to be included in the email.

The code below is made up of various different sources.

I was able to get VBA to add the email addresses BUT as there are gaps between email addresses, draft emails were being created with no email address. As I tried to solve this, I ended up losing the ability to add email addresses to the draft which was being created.

Please see below my code which needs improving:

Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Sub SendEMail()
Worksheets("Outlook Data").Select
Range("A1").Select
Rows("1:3").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp

Range("A1").Select

Dim c As Long
Dim LastRow As Long

Application.ScreenUpdating = False
LastRow = Range("A150").End(xlUp).Row

For c = LastRow To 1 Step -1

If Cells(c, 2) = Total Then
Rows(c).EntireRow.Delete
End If
Next c

Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As Integer, x As Double
For r = 1 To 100 'data in rows 1-30
' Get the email address

' Message subject
Subj = "Payment"

' Compose the message

Msg = ""
Msg = Msg & "Hi" & Cells(r, 3) & "," & vbCrLf & vbCrLf
Msg = Msg & "Please see below the associates, who are due to receive an ambassador payment this week." & vbNewLine & _
"" & vbNewLine & _
"Please can you review the names and advise if any associates should be removed from the list. If there are associates who are due an ambassador payment but that are not on the list, please advise?" & vbNewLine & _
"" & vbNewLine & _
"I would be grateful if you could respond by close of business today to ensure the correct payments are processed. Please can you also advise HR to make the changes to the shift codes on people soft." & vbNewLine & _
"" & vbNewLine & _
"If you have any questions, please do not hesitate to contact me" & vbNewLine & _
"" & vbNewLine & _
"Kind Regards" & vbNewLine & _
"" & vbNewLine

'Msg = Msg & Cells(r, 3).Text & "." & vbCrLf & vbCrLf
Msg = Msg & "Pritesh " & vbCrLf
Msg = Msg & "Payroll Specialist"

' Replace spaces with %20 (hex)
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")

' Replace carriage returns with %0D%0A (hex)
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
' Create the URL
URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg

' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus

' Wait two seconds before sending keystrokes
'Application.Wait (Now + TimeValue("0:00:02"))
'Application.SendKeys "%s"
Next r
End Sub

My aim is to skip blank cells in column A and create a draft emails with the cells with email address and have employees names included in the draft.

Sorry if this is asking to much but my brain has been frazzled playing with this all day.

If you need any more information, please let me know.

Many thanks
Pri