Range of Cells to Body of Email (Original Sig Included) Using VBA

[teaotters]

Hello!
I'm new to VBA, this is honestly my first time playing around in it, and I need some assistance.

I have a group of cells on my excel sheet that I want to have copied and pasted into the email body, but everything I try comes up with nothing. Could anyone help? I also really need my Outlook signature to populate with these emails, too. Some codes I tried before wouldn't keep it, this one seems to somehow!

I'm so sorry if this post is incorrect as well. Desperation makes me panic!

Also: The way my code is currently, I believe was going to use Word to paste a "picture" of the data, but I need the values, not just a photo. I hope this makes sense, and thank you in advance!

Sub PasteStatsToEmail()
 
    'Declare Outlook Variables
    Dim oLookApp As Outlook.Application
    Dim oLookItm As Outlook.MailItem
    Dim oLookIns As Outlook.Inspector
   
    'Declare Word Variables
    Dim oWrdDoc As Word.Document
    Dim oWrdRng As Word.Range
   
    'Declare Excel Variables
    Dim ExcRng As Range
 
   
    On Error Resume Next
   
   
    'Get The Active Instance of Outlook
    Set oLookApp = GetObject(, "Outlook.Application")
   
        'If error create a new instance of Outlook
        If Err.Number = 429 Then
       
            'Clear Error
            Err.Clear
           
            'Create a new instance of Outlook
            Set oLookApp = New Outlook.Application
           
        End If
       
       
    'Create a new Email
    Set oLookItm = oLookApp.CreateItem(olMailItem)
   
    'Create reference to Excel Range
    Set ExcRng = Sheet1.Range("R55:R81")
   
   
   
    With oLookItm
   
        'Define Info
        .To = "myboss@mybossemail.com"
        .CC = "myteam@myteamemail.com"
        .Subject = "Comparisons " & Sheet1.Range("C2")
        .Body = Sheet1.Range("R55:R81")
       
        .Display
       
        'Get Inspector
        Set oLookIns = .GetInspector
       
        'Get Word Editor
        Set oWrdDoc = oLookIns.WordEditor
       
        'Get Range from Doc
        Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content
            oWrdRng.Collapse Direction:=wdCollapseEnd
           
        'Add a new Paragraph and Insert Break
        Set oWrdRng = oWdEditor.Paragraph.Add
            oWrdRng.InsertBreak
           
        'Copy Range
        ExcRng.Copy
       
       
    End With
           
       
   
       
   

End Sub

 

[gplhl]

This code is from Ron deBruin and works with a selection. Change the command .Send to .Display to test. May also want to change Rons email from the to field! You will need both function and the sub routine. Should be simple enough to set to a range.

Copy excel table to outlook mail and keep the format

I am using VBA to send emails of a range of cells within excel. The size of the table goes haywire and all the text being wrap up when I copy over to outlook. I would want to keep the same forma...

stackoverflow.com

 

[John_w]

I have a group of cells on my excel sheet that I want to have copied and pasted into the email body, but everything I try comes up with nothing. Could anyone help? I also really need my Outlook signature to populate with these emails, too. Some codes I tried before wouldn't keep it, this one seems to somehow!

Try this macro, which creates an Outlook email with the default 'New email' signature.

Like your code, it uses Outlook's Word editor to paste the cells as an editable formatted table into the email body. I also show how to include multiple paragraphs of text above and below the pasted cells.

You'll have to edit the code to change it for your range of cells, the 'To' email address and the body text.

'References required:
'Microsoft Outlook x.00 Object Library
'Microsoft Word x.00 Object Library

Option Explicit

Public Sub Create_Email_with_Signature()

    Dim emailRange As Range
    Dim OutApp As Outlook.Application
    Dim OutEmail As Outlook.MailItem
    Dim WordDoc As Word.Document
    Dim para As Long, paraTotal As Long
    
    'Excel range to be copied and pasted into the email body
    
    Set emailRange = ThisWorkbook.Worksheets("Sheet1").Range("A1:C9")
    
    'Get active Outlook instance, if any
    
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        'Not found, so create new Outlook instance
        Err.Clear
        Set OutApp = New Outlook.Application
    End If
    On Error GoTo 0
            
    'Create new email
    
    Set OutEmail = OutApp.CreateItem(olMailItem)
    
    With OutEmail
    
        .To = "address@email.com"
        .Subject = "Email subject"
         
        .Display
        Set WordDoc = .GetInspector.WordEditor
           
        paraTotal = WordDoc.Paragraphs.Count
        para = 0
        
        'Insert paragraph(s) above the Excel range

        With WordDoc.Paragraphs(1)
            .Range.InsertBefore "Dear Xxxxx," & vbCr & vbCr & _
                                "Excel cells are shown below." & vbCr & vbCr
        End With
        
        para = para + 1 + WordDoc.Paragraphs.Count - paraTotal
        paraTotal = WordDoc.Paragraphs.Count
            
        'Copy and paste Excel range into email body
        
        With WordDoc.Paragraphs(para)
            emailRange.Copy
            .Range.Paste  'as editable table
            '.Range.PasteAndFormat Type:=wdChartPicture  'or as image
            .Range.InsertParagraphAfter
        End With
        
        para = para + 1 + WordDoc.Paragraphs.Count - paraTotal
        paraTotal = WordDoc.Paragraphs.Count

        'Insert paragraph(s) below the Excel range
        
        With WordDoc.Paragraphs(para)
            .Range.InsertBefore "Excel cells are shown above." & vbCr & vbCr & _
                                "Thanks." & vbCr
        End With

        '.Send  'send the email immediately
        
    End With
    
    Application.CutCopyMode = False

End Sub