Here is the code I am using to copy over the ranges as well as open a new excel email. I can get both to copy and paste over just fine, but my issue is that when the second picture pastes, it replaces the first picture as opposed to being pasted above it like I need it to. What am I doing wrong?
Private Sub CommandButton4_Click()
'Finds last Row of email report
Dim lRow As Long
Dim lCol As Long
lRow = Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
'Copy range of interest
Dim r As Range
Set r = Sheets("Email").Range(Cells(8, "E"), Cells(lRow, "N"))
r.Copy
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
With outMail
.To = ""
.CC = ""
.BCC = ""
.Subject = shift_txtb2.Text & " " & "Finishing Report" & " " & Format(Now(), "MM/DD/YY")
.HTMLBody = ""
'Attachments.Add
.Display
End With
''Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
''To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
Set r = Sheets("Email").Range("P8:T17")
r.Copy
wordDoc.Range.PasteAndFormat wdChartPicture
Unload Me
Sheets(1).Activate
End Sub
Put this before pasting the second one:
wordDoc.Content.InsertParagraphAfter
You can also try:
wordDoc.Content.TypeParagraph
Related
I had search all over of this question and still not get the exact codes for it.
I need to copy the color of the pivot table from excel to outlook body. When running the code i got the format but the only problem is the color of the table is turning into black and grey.
Please help me to figure it out how to put the exact color that i need.
This is my codes:
Sub AUTO_MAIL()
Dim rng As Range, rng2 As Range, rng3 As Range, rng4 As Range, sub1 As Range, sub2 As Range, sub3 As Range, sub4 As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Sheets("Data Entry").PivotTables(1).TableRange1
Set rng2 = Sheets("ACN Workflow").PivotTables(1).TableRange1
Set rng3 = Sheets("L'Oreal Workflow").PivotTables(1).TableRange1
Set rng4 = Sheets("MTD Volume").PivotTables(1).TableRange1
Set sub1 = Sheets("Data Entry").Range("A1:E1").SpecialCells(xlCellTypeVisible)
Set sub2 = Sheets("ACN Workflow").Range("A1:G1").SpecialCells(xlCellTypeVisible)
Set sub3 = Sheets("L'Oreal Workflow").Range("A1:G1").SpecialCells(xlCellTypeVisible)
Set sub4 = Sheets("MTD Volume").Range("A1:B1").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Step+ Volume Tracker, Data Entry/Workflow Ageing Report and Rejection Report |"
.HTMLBody = "<b>Dear All,</b><br><br>" & "Please see below summary of invoices and links to the <b>Volume Tracker</b> and <b>Ageing Report</b> (Data Entry and Workflow).<br>" & RangetoHTML(sub4) & vbCrLf & RangetoHTML(rng4) & vbCrLf & RangetoHTML(sub3) & vbCrLf & RangetoHTML(rng3) & vbCrLf & RangetoHTML(sub2) & vbCrLf & RangetoHTML(rng2) & vbCrLf & RangetoHTML(sub1) & vbCrLf & RangetoHTML(rng)
' In place of the following statement, you can use ".Display" to
' display the e-mail message.
.display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.SpecialCells(xlCellTypeVisible).Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
You will have to tweak the code a bit which should look something like this:
Sub due()
Dim ol As Object 'Outlook.Application
Dim olEmail As Object 'Outlook.MailItem
Dim olInsp As Object 'Outlook.Inspector
Dim wd As Object 'Word.Document
Dim rCol As Collection, r As Range, i As Integer
'/* if outlook is running use GO, create otherwise */
Set ol = GetObject(Class:="Outlook.Application")
Set olEmail = ol.CreateItem(0) 'olMailItem
Set rCol = New Collection
With rCol
.Add Sheet1.Range("A1:B6") '/* add your ranges the same sequence */
.Add Sheet2.Range("A1:B6") '/* as you want them added in the body */
End With
With olEmail
.To = ""
'/* bonus basic html */
.HTMLBody = "<html><body style=""font-family:calibri"">" & _
"<p><b>Dear Deer,</b><br><br> She see seas." & _
"</p></body></html>"
Set olInsp = .GetInspector
If olInsp.EditorType = 4 Then 'olEditorWord
Set wd = olInsp.WordEditor
For i = 1 To rCol.Count '/* iterate all ranges */
Set r = rCol.Item(i): r.Copy
wd.Range.InsertParagraphAfter
wd.Paragraphs(wd.Paragraphs.Count).Range.PasteAndFormat 16
'16 - wdFormatOriginalFormatting
Next
End If
wd.Range.InsertParagraphAfter
wd.Paragraphs(wd.Paragraphs.Count).Range.Text = "Regards, Patricia"
wd.Paragraphs.Last.Range.Sentences.Last.Font.Bold = True
.Display
End With
End Sub
In case you want to do more, you will have to read more about Word VBA. This is just a sample on what you can do with Outlook's Word Editor.
I send an email to a list of people. The email is generated by copying a range from one Excel sheet into the body of the email. This works fine.
All the code is below. The sheet that the body of the mail is selected from is called 'UKX Trade". I want to retrieve the email address data from a separate sheet called "Mailinfo". How can I adjust the code for this to work?
Sub ZC_Collar()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim StrBody As String
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Range("ZCCollar").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
StrBody = Sheets("UKX Trade").Range("body_line1").Value & "<br><br>" & _
Sheets("UKX Trade").Range("body_line2").Value & "<br>" & _
Sheets("UKX Trade").Range("body_line3").Value
Set OutApp = CreateObject("Outlook.Application")
On Error Resume Next
For Each cell In Columns("P").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "Q").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Index Option RFQ"
.CC = Range("cc_email").Value
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & "Thanks"
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
You just need to specify where cell is in this line:
For Each cell In Columns("P").Cells.SpecialCells(xlCellTypeConstants)
' ... add contacts code
Next cell
Do this by:
For Each cell In ThisWorkbook.Sheets("Mailinfo").Columns("P").Cells.SpecialCells(xlCellTypeConstants)
' ... add contacts code
Next cell
This is called fully qualifying an object in VBA.
Edit
So here is your sub, but with things fully qualified. You'll notice that the code you got from Ron de Bruin (RangetoHTML) was already fully qualified. Put this in a module not a sheet.
Sub ZC_Collar()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim StrBody As String
Set rng = Nothing
On Error Resume Next
' Remove this next line, it doesn't do anything because you set rng again anyway
' Set rng = Selection.SpecialCells(xlCellTypeVisible)
' only visible cells in ZCCollar range, specifying the sheet (put the correct sheet in)
Set rng = ThisWorkbook.Sheets("UKX Trade").Range("ZCCollar").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With ThisWorkbook.Sheets("UKX Trade")
StrBody = .Range("body_line1").Value & "<br><br>" & _
.Range("body_line2").Value & "<br>" & _
.Range("body_line3").Value
End With
Set OutApp = CreateObject("Outlook.Application")
On Error Resume Next
For Each cell In ThisWorkbook.Sheets("Mailinfo").Columns("P").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And LCase(ThisWorkbook.Sheets("Mailinfo").Cells(cell.Row, "Q").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Index Option RFQ"
.CC = ThisWorkbook.Sheets("Mailinfo").Range("cc_email").Value
.HTMLBody = StrBody & RangetoHTML(rng) & "<br>" & "Thanks"
.Display 'Or use Send to send each email without displaying it first
End With
Set OutMail = Nothing
End If
Next cell
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I'm fairly new to VBA.
I've figured a way to send a mail picking up content from the table and sending it to the desired recipient using a macro.
Now, I need to send mails with different content to multiple recipients, all the required data is present in the same table, with the recipient name being one of the columns. Any help would be greatly appreciated.
Private Sub CommandButton1_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Dim LastRow As Long
StrBody = "Hi," & "<br>" & "<br>" & _
"The following Talents were last reporting to you and have now moved to bench. Please confirm the plans. " & "<br><br>"
With Worksheets("To-Bench")
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set rng = Nothing
On Error Resume Next
'For Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'For fixed range
Set rng = Sheets("To-Bench").Range("A1:G2").SpecialCells(xlCellTypeVisible)
'Hardcoded the number of rows which is actually indefinite'
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
'Application.Goto ActiveWorkbook.Sheets("Sheet2").Cells(6, 5)
.To = ActiveSheet.Cells(2, 9).Text 'I've hardcoded the recipient as of now'
.CC = ""
.BCC = ""
.Subject = "Movement of " & Range("C2").Value & " Talents to Bench"
.HTMLBody = StrBody & rangetoHTML(rng)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function rangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
rangetoHTML = ts.readall
ts.Close
rangetoHTML = Replace(rangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Try this solution from Ron deBruin.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
If you need to merge several cells into a single cell, you can concatenate a range using the following method.
Function ConcRange(ByRef myRange As Range, Optional ByVal Seperator As String = ";")
ConcRange = vbNullString
Dim rngCell As Range
For Each rngCell In myRange
If ConcRange = vbNullString Then
If Not rngCell.Value = vbNullString Then
ConcRange = CStr(rngCell.Value)
End If
Else
If Not rngCell.Value = vbNullString Then
ConcRange = ConcRange & Seperator & CStr(rngCell.Value)
End If
End If
Next rngCell
End Function
I gather the data from different Excel sheets and paste the table and content in one sheet and then push that to html file to Outlook.
While pasting the data from the sheet to html file, it is calculating the number of columns in which the data is present.
For Example in one sheet I have pasted text which is around 500 characters on the very first row. On the next row I have pasted a 5*10 table. While copying data to html file it is calculating only 10 columns and copying the data which is in yellow in screenshot.
How do I copy all the data from Excel to html file.
If I use Sheet.UsedRange then on the basis of column it is copying data.
Code:
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim htmlContent
Dim RangetoHTML
Dim lastColumn
Dim lastRow
Dim LastCol
Dim TempFile As String
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name "Signature" And ws.Name "URL") Then
Set rng = Nothing
Set rng = ws.UsedRange
lastRow = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
Set rng = Range(Cells(1, 1), Cells(lastRow, 20))
'Publish the sheet to a htm file
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ws.Name, _
Source:=ws.UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
htmlContent = htmlContent & RangetoHTML
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange
End If
Next ws
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "sagarwal4#dow.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = htmlContent
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Use something like this instead:
Dim lastCell As Excel.Range
Set lastCell = Cells.Find(What:="*", After:=Cells(1, 1), Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False)
Range("A1", lastCell).Copy
'// Rest of code here ....
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
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.
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
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