Call Function To Send Email Without So Much Code In Excel - vba

Question

I have an excel spreadsheet that select pre-defined cells and from this creates and email when a user presses a button. This worked fine when I had about 3 to 4 rows of data but now I have over 500 rows.
What I would like to do is instead of duplicating the code for each row is have one function that gets called on each time. I want the code to work out the row from a link at the end of the Row (which I also need to figure out how to link to the VBA, I know how to do it via a button but a link at the end of each row would be much better). The Link will say send email. If the user presses this link, then it will select the row the link is on and send the email. Hope that makes sense. I just wanted 1 function this could be called from. Instead of having to duplicate the code each time for each row.
Any good ways of doing this? Please see my code and spreadsheet below.
Sub SendEmail()
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
Dim objEmail As Outlook.MailItem
Set objEmail = objOutlook.CreateItem(olMailItem)
objEmail.Subject = Cells(2, 1).Text
objEmail.Body = "============" & vbNewLine & Cells(2, 3).Text & vbNewLine & "============" & vbNewLine & Cells(2, 6).Text
objEmail.To = Cells(2, 5).Text
objEmail.SentOnBehalfOfName = "test#test.com"
objEmail.Display
End Sub
I have also attached an example of my spreadsheet. Please note the full on spreadsheet has over 500 records. This is a much condensed version:
>> LINK to sample workbook

Answer 1

You can also try below:
Sub SendEmail(r As Range)
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
Dim objEmail As Outlook.MailItem
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.Subject = r.Value2
.Body = "============" & vbNewLine & r.Offset(0, 2).Value2 & vbNewLine & _
"============" & vbNewLine & r.Offset(0, 5).Value2
.To = r.Offset(0, 4).Value2
.SentOnBehalfOfName = "test#test.com"
.Display
End With
End Sub
Then test it:
Sub Test()
Dim lr As Long, cel As Range
With Sheets("SheetName")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
If lr = 1 Then Msgbox "No email to send": Exit Sub
For Each cel In .Range("A2:A" & lr)
SendEmail cel
Next
End With
End Sub
Edit: To send mail when hyperlink is pressed, you can use a worksheet event.
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.EnableEvents = False
On Error GoTo halt
If Target.Name = "Send Mail" Then '<~~ Check which hyperlink is pressed
'*** This will call the SendEmail routine above and pass
'*** the range where the hyperlink is on
'*** Take note of the Offset(0, -5). I just based it on your screen shot
'*** where your subject is 5 cells from the cell with Send mail
'*** Adjust it to your actual target range
Application.Run SendEmail, Target.Range.Offset(0, -5)
'SendEmail Target.Range.Offset(0, -5)
End If
moveon:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume moveon
End Sub
I used Application.Run so that you don't have to worry whether your SendEmail sub routine is Public or not. If you decide to just make it Public in a Module, you can use the commented line.

Answer 2

Use the row from the selection. Select your row, then get the row from the selected range, and use it in your code for the cells(iRow, 1)
Sub SendEmail()
Dim ActSheet As Worksheet
Dim SelRange As Range
Dim iRow As Integer
Set ActSheet = ActiveSheet
Set SelRange = Selection
iRow = SelRange.Row
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
Dim objEmail As Outlook.MailItem
Set objEmail = objOutlook.CreateItem(olMailItem)
objEmail.Subject = Cells(iRow , 1).Text
objEmail.Body = "============" & vbNewLine & Cells(iRow , 3).Text & vbNewLine & "============" & vbNewLine & Cells(iRow , 6).Text
objEmail.To = Cells(iRow , 5).Text
objEmail.SentOnBehalfOfName = "test#test.com"
objEmail.Display
End Sub

Answer 3

Here how you get all the rows and run your sub on all the rows.
Sub sendEmailFromAllRows()
'Getting the last used row
With Sheets("YourSheetName")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastrow = 1
End If
End With
'Calling your sub to send the mail for each row
For i = 2 To lastrow
SendEmail (i)
Next i
End Sub
Sub SendEmail(iRow As Integer)
Dim objOutlook As Outlook.Application
Set objOutlook = New Outlook.Application
Dim objEmail As Outlook.MailItem
Set objEmail = objOutlook.CreateItem(olMailItem)
objEmail.Subject = Cells(iRow, 1).Text
objEmail.Body = "============" & vbNewLine & Cells(iRow, 3).Text & vbNewLine & "============" & vbNewLine & Cells(iRow, 6).Text
objEmail.To = Cells(iRow, 5).Text
objEmail.SentOnBehalfOfName = "test#test.com"
objEmail.Display
objEmail.Send
End Sub