Excel Multiple Ranged Cells to Outlook

[N3cTr0]

Hi,

I've checked a few videos even tried AI but I am struggling with this code, I want it to take 2 ranges and send it in an email, but the 2nd range always seems to override the 1st one, and thus only the 2nd table appears.

Sub SendEmail()
Dim shtSummary As Worksheet
Dim shtStats As Worksheet
Dim LastRowSummary As Long
Dim LastRowStats As Long
Dim rngSummary As Range
Dim rngStats As Range
Dim OutApp As Object
Dim OutMail As Object

' Set the summary sheet and the last row to copy
Set shtSummary = ThisWorkbook.Sheets("Summary")
LastRowSummary = shtSummary.Cells(shtSummary.Rows.Count, "I").End(xlUp).Row

' Define the summary range to copy
Set rngSummary = shtSummary.Range("I1:O" & LastRowSummary)

' Set the stats sheet and the last row to copy
Set shtStats = ThisWorkbook.Sheets("Stats")
LastRowStats = shtStats.Cells(shtStats.Rows.Count, "A").End(xlUp).Row

' Define the stats range to copy
Set rngStats = shtStats.Range("A1:Y" & LastRowStats)

' Create a new email and paste the ranges into the body
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Reports"
.Display

'Copy the summary range and paste it into the email body
rngSummary.Copy
.GetInspector.wordEditor.Range.PasteAndFormat wdTableOverwriteStyle


'I'm guessing something needs to be between the two so that they can be separated?


' Copy the stats range and paste it into the email body
rngStats.Copy
.GetInspector.wordEditor.Range.PasteAndFormat wdTableOverwriteStyle

End With

' Clear the clipboard
Application.CutCopyMode = False
End Sub

 

[John_w]

I want it to take 2 ranges and send it in an email, but the 2nd range always seems to override the 1st one, and thus only the 2nd table appears.

Try this macro. The code also shows how to insert text before and after the pasted ranges.

Public Sub Create_Email()

    Dim shtSummary As Worksheet
    Dim shtStats As Worksheet
    Dim LastRowSummary As Long
    Dim LastRowStats As Long
    Dim rngSummary As Range
    Dim rngStats As Range
    
    Dim olApp As Outlook.Application
    Dim olEmail As Outlook.MailItem
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Word.Document

    ' Define the summary range to copy
    With ThisWorkbook.Worksheets("Summary")
        Set rngSummary = .Range("I1:O" & .Cells(.Rows.Count, "I").End(xlUp).Row)
    End With
    
    ' Define the stats range to copy
    With ThisWorkbook.Worksheets("Stats")
        Set rngStats = .Range("A1:Y" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With

    Set olApp = New Outlook.Application
    Set olEmail = olApp.CreateItem(olMailItem)

    With olEmail
        .BodyFormat = olFormatRichText
        .Display

        .To = ""
        .Subject = "Reports"

        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor

        With wdDoc.Range
            .InsertBefore "Summary range:"
            .InsertAfter vbCrLf
    
            rngSummary.Copy
            PasteAtEnd wdDoc
    
            .InsertAfter vbCrLf & vbCrLf
            .InsertAfter "Stats range:"
    
            rngStats.Copy
            PasteAtEnd wdDoc
        
            .InsertAfter vbCrLf & vbCrLf
            .InsertAfter "End of data"
        End With

    End With

End Sub

'paste from clipboard to the end of the document
Private Sub PasteAtEnd(doc As Word.Document)
    With doc
        .Content.Select
        .Application.Selection.Collapse wdCollapseEnd
        .Application.Selection.PasteAndFormat wdChartPicture
    End With
End Sub

 

[N3cTr0]

Your awesome thanks, will play around with that.