VBA - Copying Range to an E-Mail Body

[cwhaley1]

Hi all, I have a spreadsheet which pulls through the data contained on 5 SharePoint spreadsheets into a separate Excel spreadsheet. This uses Power Query. This is working well and odes what I need.

I have written a crude VBA code which refreshes all the data connections, takes a copy of the tables from each tab and pastes them onto a tab within the sheet. I would then like this range of data to be copied into an e-mail body.

I don't understand why the below code won't fully work. The part I'm struggling with is

 .Body = Range("B2:K44")

but I have pasted the full code below for clarity. Excel tells me "the object does not support this method". All the code above works absolutely fine.

Sub Filter_Controller()

 Application.ScreenUpdating = False
    Dim OutApp As Object, OutMail As Object, email As Range
    Set OutApp = CreateObject("Outlook.Application")
    Dim ws As Worksheet
    Dim r As Range
    
    
    Worksheets("Project_Set_Up_Checks").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
    ActiveSheet.ListObjects("Project_Set_Up_Checks").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
          
    Worksheets("Opportunity_Contact_Checks").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
    ActiveSheet.ListObjects("Opportunity_Contact_Checks").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
  
    Worksheets("Opportunity_Contacts").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
    ActiveSheet.ListObjects("Opportunity_Contacts").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
    
    Worksheets("Live_Projects_Last_Booking").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
     ActiveSheet.ListObjects("Live_Projects_Last_Booking").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
       
    Worksheets("Potential_Closures_No_Comment").Activate
    With ActiveSheet.ListObjects(1)
    If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
End With
     ActiveSheet.ListObjects("Potential_Closures_No_Comment").Range.AutoFilter Field:=2, Criteria1:= _
       Sheets("Main").Range("F5")
       
       
       Sheets("Project_Set_Up_Checks").Select
        Range("A1").CurrentRegion.Select
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B22").Select
    ActiveSheet.Pictures.Paste.Select
    Sheets("Opportunity_Contact_Checks").Select
    Range("A1").CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B26").Select
    ActiveSheet.Pictures.Paste.Select
    Sheets("Opportunity_Contacts").Select
    Range("A1").CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B30").Select
    ActiveSheet.Pictures.Paste.Select
    Sheets("Live_Projects_Last_Booking").Select
    Range("A1").CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B34").Select
    ActiveSheet.Pictures.Paste.Select
    Sheets("Potential_Closures_No_Comment").Select
    Range("A1").CurrentRegion.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("E-Mail Body").Select
    Range("B38").Select
    ActiveSheet.Pictures.Paste.Select
    Range("B4:AD41").Select
            
               
    
 Application.ScreenUpdating = False
   
    
    Worksheets("Main").Activate
    'Cells.SpecialCells(xlCellTypeFormulas, xlErrors).Clear
                
    For Each email In Range("J4", Range("J" & Rows.Count).End(xlUp))
        Set OutMail = OutApp.CreateItem(0)
            With OutMail
            .SentOnBehalfOfName = "e-mail goes here" 'this is the "from" field
            .To = email
            .Subject = "Data Cleansing Reminder - " & Date
            .Body = Range("B2:K44") 'this references the cell where the body of the e-mail is written
            .Save
            .Display
            '.send '<<<<<to send without the option of reviewing first, remove the "'"
        End With
    Next email
    Application.ScreenUpdating = True
  
            
Worksheets("E-Mail Body").Select

ActiveSheet.Pictures.Delete

End Sub

 

[Logit]

Here is the "guts" of the email macro. You'll need to add to it as you see fit to accomplish the remainder of your
project goal :

Sub SendEmailWithRange()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim MailBody As String
    Dim i As Integer, j As Integer
    Dim rng As Range
    Dim cell As Range
    
    ' Set the range to be copied
    Set rng = ThisWorkbook.Sheets("Main").Range("B2:K44")
    
    ' Construct the mail body
    MailBody = ""
    For i = 1 To rng.Rows.Count
        For j = 1 To rng.Columns.Count
            MailBody = MailBody & rng.Cells(i, j).Value & vbTab
        Next j
        MailBody = MailBody & vbNewLine
    Next i
    
    ' Create an instance of Outlook application
    Set OutlookApp = CreateObject("Outlook.Application")
    
    ' Create a new mail item
    Set OutlookMail = OutlookApp.CreateItem(0)
    
    ' Set mail properties
    With OutlookMail
        .SentOnBehalfOfName = "e-mail goes here" 'this is the "from" field
        .To = "recipient@example.com"
        .Subject = "Range B2:K44 from Sheet Main"
        .Body = MailBody
        '.Send
        .Display
    End With
    
    ' Clean up
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

 

[cwhaley1]

Many thanks for this Logit. I'll incorporate it into my code and report back on here if it's my solution.

 

[cwhaley1]

I've incorporated your code and made a few changes and can confirm it does what I want which is great.

Thanks for your help - it's taught me a better way of writing code to create an e-mail.

 

[Logit]

Glad to help. Cheers.