Giritharanj
New Member
- Joined
- Mar 24, 2019
- Messages
- 7
Im new to vba coding and trying to create a macro code for send email to multplie users with range to data in a row. Like name in A2 to data in H2. My data is in sheet named "TAT".
<tbody>
</tbody>
I should send corresponding row in email with table format.
By searching the foruom I have got to the below code to get the table. BUt im not able to do looping corresponding row for each of the unique row.
| Names | SLO 0-25% | SLO 25-50% | SLO 50-75% | SLO 75-100% | SLO 100%+ | Count of Requests | |
| abc@outlook.com | Harry | 66.7% | 0.0% | 0.0% | 33.3% | 0.0% | 3.00 |
| abd@outlook.com | Garry | 54.4% | 40.4% | 5.3% | 0.0% | 0.0% | 57.00 |
| fbc@outlook.com | Terry | 54.4% | 40.4% | 5.3% | 0.0% | 0.0% | 57.00 |
| agju@outlook.com | Jerry | 54.4% | 40.4% | 5.3% | 0.0% | 0.0% | 57.00 |
<tbody>
</tbody>
I should send corresponding row in email with table format.
By searching the foruom I have got to the below code to get the table. BUt im not able to do looping corresponding row for each of the unique row.
Code:
<code>
[FONT=tahoma]Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim Row As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Dim x As Long
Dim cell As Range
For x = 2 To Range("A1").End(xlDown).Row
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Worksheets("TAT").Range("A1:H2")
If rng Is Nothing Then
MsgBox "An unknown error has occurred. "
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'RangetoHTML(rng) = (Row.Offset(0, 1) & Row.Offset(0, 2) & Row.offSet(0, 3))
On Error Resume Next
With OutMail
.To = Cells(x, 1).Value
.CC = ""
.BCC = ""
.Subject = "Your TAT Report "
.HTMLBody = ActiveCell.Offset(0, -1) & "," & "
" & "Please find your individual TAT status below," & "
" & _
RangetoHTML(rng) & "
" & strbody & _
"Text below Excel cells.
"
.Display
' .Send
End With
On Error GoTo 0
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutMail = Nothing
Set OutApp = Nothing
ActiveCell.Offset(1, 0).Select
Next
End Sub
===============================================================================
Function RangetoHTML(rng As Range)
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
[/FONT]
</code>
Last edited by a moderator:
