Copy multiple range in mail

Question

I want to send an email to Row 4 to be constant and Row 5 to be dynamic. First mail will include Row4 and below Row5 data then second mail will include Row4 and below Row6 data and so on.

Sub Send_Range_Or_Whole_Worksheet_with_MailEnvelope()
'Working in Excel 2002-2016
    Dim AWorksheet As Worksheet
    Dim Sendrng As Range
    Dim rng As Range

    On Error GoTo StopMacro

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Fill in the Worksheet/range you want to mail
    'Note: if you use one cell it will send the whole worksheet
    Set Sendrng = Application.Union(Range("A4"), Range("A6")).EntireRow

    'Remember the activesheet
    Set AWorksheet = ActiveSheet

    With Sendrng

        ' Select the worksheet with the range you want to send


        'Remember the ActiveCell on that worksheet

        'Select the range you want to mail
        .Select

        ' Create the mail and send it
        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope

            ' Set the optional introduction field thats adds
            ' some header text to the email body.
            .Introduction = "This is test mail 2."

            With .Item
                .To = "xxxx"
                .CC = ""
                .BCC = ""
                .Subject = "My subject"
                .Body = Sendrng
                .Send
            End With

        End With

        'select the original ActiveCell
        rng.Select
    End With

    'Activate the sheet that was active before you run the macro
    AWorksheet.Select

StopMacro:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    ActiveWorkbook.EnvelopeVisible = False

End Sub

I tried using this code but it does not send the desired range. I don't want to copy and paste data to another sheet and then send mail because it slows down the macro as I need to send mail to more than 60 people.

Is there any way that we can send the selected ranges in the mail? I have also attached a sample image for your reference.

Answer 1

Try the following for starters:

Sub Send_Range_Or_Whole_Worksheet_with_MailEnvelope()

    On Error GoTo StopMacro

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    Dim AWorksheet As Worksheet
    Dim Sendrng As Range
    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim loopRange As Range

    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("Sheet1")

    wsSource.Cells.EntireRow.Hidden = False

    Set loopRange = wsSource.Range("A4").CurrentRegion 'Could also use last row method

    Dim currentName As Long

    For currentName = 2 To loopRange.Rows.Count

        loopRange.EntireRow.Hidden = True

        Union(loopRange.Rows(1), loopRange.Rows(currentName)).EntireRow.Hidden = False

        Set Sendrng = loopRange.SpecialCells(xlCellTypeVisible)

        Set AWorksheet = ActiveSheet

        With Sendrng

            .Parent.Select

            Set rng = ActiveCell

            .Select

            ActiveWorkbook.EnvelopeVisible = True

            With .Parent.MailEnvelope

                .Introduction = "This is test mail 2."

                With .Item
                    .to = "xxx"
                    .CC = ""
                    .BCC = ""
                    .Subject = "My subject"
                    .Send                        '.Display
                End With

            End With

        End With

    Next currentName

StopMacro:

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With

    ActiveWorkbook.EnvelopeVisible = False

    wsSource.Cells.EntireRow.Hidden = False

End Sub

Additional note:

If you want to use a last row method rather than CurrentRegion for setting the loopRange then you can replace

  Set loopRange = wsSource.Range("A4").CurrentRegion 'Could also use last row method

With

Dim lastRow As Long

With wsSource
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Set loopRange = wsSource.Range("A4:C" & lastRow)

Version 2 Tidier:

And here is a version 2 which I prefer as is tidier (Based on answer by Paul-Jan):

Public Sub Send_Range()

    Dim wb As Workbook
    Dim wsSource As Worksheet
    Dim loopRange As Range

    On Error GoTo StopMacro

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    On Error GoTo StopMacro

    Set wb = ThisWorkbook
    Set wsSource = wb.Worksheets("Sheet1")

    wsSource.Cells.EntireRow.Hidden = False

    Dim StrBody As String

    StrBody = "This is test mail 2.," & "<br>" & "<br>" & _
              "Please find you marks below." & "<br><br>"


    Dim lastRow As Long

    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

    Set loopRange = wsSource.Range("A4:C" & lastRow)

    Dim currentName As Long

    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")

    For currentName = 2 To loopRange.Rows.Count

        Set OutMail = OutApp.CreateItem(0)

        loopRange.EntireRow.Hidden = True

        Union(loopRange.Rows(1), loopRange.Rows(currentName)).EntireRow.Hidden = False

        Set Sendrng = loopRange.SpecialCells(xlCellTypeVisible)

        With OutMail
            .To = "xxx"
            .CC = ""
            .BCC = ""
            .Subject = ""
            .HTMLBody = StrBody & RangetoHTML(Sendrng)
            .Send                                'or use .Display
        End With


    Next currentName


StopMacro:

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

     wsSource.Cells.EntireRow.Hidden = False

End Sub


Private Function RangetoHTML(ByVal rng As Range)
' By Ron de Bruin.
    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