# VBA code to send email to unique mail id given in a cell with the subsequent columns



## Giritharanj (Mar 24, 2019)

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".


*Email**Names**SLO  0-25%**SLO   25-50%**SLO 50-75%**SLO 75-100%**SLO 100%+**Count of Requests*abc@outlook.comHarry66.7%0.0%0.0%33.3%0.0%3.00abd@outlook.comGarry54.4%40.4%5.3%0.0%0.0%57.00fbc@outlook.comTerry54.4%40.4%5.3%0.0%0.0%57.00agju@outlook.comJerry54.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>
[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>
```


----------



## Logit (Mar 24, 2019)

.
This will do the job.

You will need to edit the code for COL where your email addresses are located. Also, this macro uses SHEET2 as a temporary location
for copying/pasting each row so it can place that row into each individual email. Change the SHEET name as desired.


```
Option Explicit


Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2") '<-----------------------------------------------------------------------------------edit sheet name


For i = 2 To ws1.Range("B65536").End(xlUp).Row
    If ws1.Cells(i, 7) Or ws1.Cells(i, 10) = "=Today()" Then ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
    Mail_Selection_Range_Outlook_Body
    ws2.Rows.Delete
Next i
End Sub


Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets("Sheet2").Range("A2:J2" & lEndRow).SpecialCells(xlCellTypeVisible) '<--------------------------------------------------------------edit range of columns to "A2: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)
With OutMail
    .To = Sheets("Sheet2").Range("D2").Value '<-----------------------------------------------------------------------------edit email column reference
    .CC = ""
    .BCC = ""
    .Subject = "Please review the latest Forecast Variable Report"


    .HTMLBody = Sheets("Sheet2").Range("B2").Value & "<p>Text above Excel cells" & "<br><br>" & _ '<--------------------------------------------------recipient's name location ( Column )
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    
    ' 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)
    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
```


----------



## Giritharanj (Mar 25, 2019)

Logit said:


> .
> This will do the job.
> 
> You will need to edit the code for COL where your email addresses are located. Also, this macro uses SHEET2 as a temporary location
> ...



Thanks for your time, Im' getting Syntax error at .HTMLBody. Could you please help me here.

Code: *   .HTMLBody = Sheets("Sheet2").Range("B2").Value & "**Text above Excel cells" & "

" & _ '<--------------------------------------------------recipient's name location ( Column )
                RangetoHTML(rng) & "

" & _
                "Text below Excel cells.*​*"*


----------



## Giritharanj (Mar 25, 2019)

I'm getting a Type MisMatch error.

 Code:
RangetoHTML (rng) & "" & "Text below Excel cells."


----------



## Logit (Mar 28, 2019)

.
Giritharanj 

Disregard the previous suggested macro. The following has been tested here and I believe based on your description, this will
do what you are seeking. If you have any issues please do not hesitate to ask.




```
Option Explicit


Sub Mail_Selection_Range_Outlook_Body2()
Dim rng As Range
Dim Row As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Value As String
Dim x As Long
Dim cell As Range
Dim hdr As Range


For x = 2 To Range("A1").End(xlDown).Row
Set rng = Nothing


    
' Only send the visible cells in the selection.
Set rng = Range(Cells(x, 3), Cells(x, 8))
Set hdr = ActiveSheet.Range("C1:H1")


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)


With OutMail
    .To = Cells(x, 1).Value
    .CC = ""
    .BCC = ""
    .Subject = "Your TAT Report "
    .HTMLBody = Cells(x, 2).Value & ", " & "please find your individual TAT status below." _
                & "<br></br>" & "<br></br>" & RangetoHTML(hdr) & RangetoHTML(rng) & "<br></br>" & "<br></br>" & "Text below Excel cells."
    
    .Display
   ' .Send
    
End With
Next x
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutMail = Nothing
Set OutApp = Nothing
ActiveCell.Offset(1, 0).Select


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
```


----------



## Giritharanj (Mar 28, 2019)

Hi Logit,

Thank you so much for your time & help. it worked perfect & flawless.


----------



## Logit (Mar 28, 2019)

You are welcome.


----------

