• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA Code or Macro to Email a specific row to a user

Sriram Iyengar

New Member
Hi Team,

I have close to 60 rows of data in an excel file for 60 users. I want to send this data to them individually along with the Row Headers.

Attached is a sample file. Can you please help with the same?
 

Attachments

Logit

Active Member
This is one method :

Code:
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 = 3 To Range("L3").End(xlDown).Row
Set rng = Nothing

'On Error Resume Next
    
' Only send the visible cells in the selection.
Set rng = Range(Cells(x, 1), Cells(x, 11))
Set hdr = ActiveSheet.Range("A2:K2")
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, 12).Value
    .CC = ""
    .BCC = ""
    .Subject = "Regarding Handling Times "
    .HTMLBody = "Greetings, " & Cells(x, 2).Value & _
                "<br></br>" & "<br></br>" & RangetoHTML(hdr) & RangetoHTML(rng) & "<br></br>" & "<br></br>" & "Thank you."
    
    .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
 

Attachments

Logit

Active Member
The macro as displayed in my last post works as shown.

The file you attached works as intended.

The error message you are receiving seems to be indicative of attempting to attach the workbook to the email which is not part of the macro
requested.

?????
 
Top