Automating Reports - Pasting Tables into Email

O

oddzac

New Member
Joined
Aug 12, 2022
Messages
25
Office Version
  1. 365
  2. 2021
  3. 2019
Platform
  1. Windows
Hi all, I'm running a basic macro to copy/paste/format emails to simplify reports that I'm handing off to my team.

(This will be the 3rd question I've posted here this weekend and I'm immensely grateful for all of the support and patience you've all shown)

As with most of my other questions, I've got a macro that *functionally* works, but it's missing the part that makes it look like I know what I'm doing..
The macro runs through 4 separate ranges in a worksheet. For each range it copies the selected area, pastes it into the email and centers the pasted table.

The issue I'm having is that even with
VBA Code: 
.Range.InsertParagraphBefore
to create a new line, My tables seem to be nesting inside of each other.

Dims for context:
VBA Code: 
Sub Macro7()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim rng As Range
    Dim OutApp As Object
    Dim outMail As Object
    Dim Location As String
    Dim Signature As String
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

'Open new mail item

    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Set outMail = outlookApp.CreateItem(0)
    
'Get Word editor

    outMail.Display
    Dim wordDoc As Object
    Set wordDoc = outMail.GetInspector.WordEditor




The Problem Code:

VBA Code: 
'Copy contents

    Sheets("Tables").Select
    Range("AB7:AI75").Select
    Range("AB7").Activate
    Selection.Copy

'Paste as image (Centered)
    
    
    wordDoc.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    wordDoc.Paragraphs.first.Range.PasteAndFormat Type:=wdChartPicture
    wordDoc.Range.InsertParagraphBefore
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
   
   
   
'======== SECOND TABLE ========
'Copy contents (2)

    Sheets("Tables").Select
    Range("P7:Z29").Select
    Range("P7").Activate
    Selection.Copy
   
'Paste as image (Centered)(2)
    
    wordDoc.Range.InsertParagraphBefore
    wordDoc.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    wordDoc.Paragraphs.first.Range.PasteAndFormat Type:=wdChartPicture
    
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
        
    
    End With
    
    
'======== THIRD TABLE ==========
'Copy contents (3)

    Sheets("Tables").Select
    Range("F7:M30").Select
    Range("F7").Activate
    Selection.Copy
   
'Paste as image (Centered)(3)
    
  
    wordDoc.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    wordDoc.Paragraphs.first.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With


etc. etc.


So obviously I'm just copy/pasting my way through this and it felt great when the first two went in and looked right (similar widths), but the rest.. well, not so much..

1676834115783.png



Mainly, I'm just looking for a way to insert some type of break between the tables so they aren't connected.

Thoughts?
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
Current Code update:

VBA Code: 
Sub Macro7()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim rng As Range
    Dim OutApp As Object
    Dim outMail As Object
    Dim Location As String
    Dim Signature As String
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

'Open new mail item

    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Set outMail = outlookApp.CreateItem(0)
    
'Get Word editor

    outMail.Display
    Dim wordDoc As Object
    Set wordDoc = outMail.GetInspector.WordEditor

'Save Sig

    With wordDoc
        
        wordDoc.Paragraphs.first.Range.InsertParagraphBefore
        wordDoc.Range.Paragraphs.Alignment = 1
        wordDoc.Range.Paragraphs.Add Range:=wordDoc.Paragraphs(1).Range
        
    
    End With
   

    
'Copy contents

    Sheets("Tables").Select
    Range("AB7:AI75").Select
    Range("AB7").Activate
    
    Selection.Copy

'Paste as image (Centered)
    
    
    wordDoc.Paragraphs.first.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    wordDoc.Paragraphs.first.Range.InsertParagraphBefore 'Create another
    wordDoc.Paragraphs.first.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
   
'======== SECOND TABLE ========
'Copy contents (2)

    Sheets("Tables").Select
    Range("P7:Z29").Select
    Range("P7").Activate
    Selection.Copy
   
'Paste as image (Centered)(2)
    
    wordDoc.Paragraphs.first.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    wordDoc.Paragraphs.first.Range.InsertParagraphBefore 'Create another
    wordDoc.Paragraphs.first.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    
    With wordDoc.Tables(2).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
    
    
'======== THIRD TABLE ==========
'Copy contents (3)

    Sheets("Tables").Select
    Range("F7:M30").Select
    Range("F7").Activate
    Selection.Copy
   
'Paste as image (Centered)(3)
    
    wordDoc.Paragraphs.first.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    wordDoc.Paragraphs.first.Range.InsertParagraphBefore 'Create another
    wordDoc.Paragraphs.first.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(3).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With


The issue now is that they paste *above* my default signature. I've plugged in ".first" to replace ".last" within the "Paste as Image (Centered)" sections but I'm getting an error (91 : Object variable or With block variable not set) for the PasteAndFormat line
 
Upvote 0
So this is what I wound up with if anyone makes it here with a similar question:

VBA Code: 
Sub Recap_Email()


    Dim rng As Range
    Dim OutApp As Object
    Dim outMail As Object
    Dim Location As String
    Dim Signature As String
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    

    
   
'Set Indicator to White, Save Workbook & Lock Email Macro
    Range("N7:O10").Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.OnAction = "Oops"
    Range("N7:O10").Select
    ActiveWorkbook.Save
    

'In Progress, Red (only visible if macro throws error)

    Range("N7:O10").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 192
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

'Open new mail item

    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Set outMail = outlookApp.CreateItem(0)
    
'Get Word editor

    outMail.Display
    Dim wordDoc As Object
    Set wordDoc = outMail.GetInspector.WordEditor
    
    
    
'Save Sig

    With wordDoc
        
        
        wordDoc.Range.Paragraphs.Alignment = 1
        wordDoc.Range.Paragraphs.Add
        wordDoc.Paragraphs.first.Range.InsertParagraphBefore
    
    End With


    
'Copy contents

    Sheets("Setup").Select
    Range("H13:K32").Select
    Range("H13").Activate
    Selection.Copy



'Paste as image (Centered)
    
    Dim insertPoint As Object
    wordDoc.Paragraphs.first.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    Set insertPoint = wordDoc.Paragraphs.first
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
    
'======== SECOND TABLE ========
'Copy contents (3)

    Sheets("Tables").Select
    Range("A8:B75").Select
    Range("A8").Activate
    Selection.Copy
   
'Paste as image (Centered)(3)
    
    insertPoint.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(2).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With

    
'======== THIRD TABLE ==========
'Copy contents (3)


    Sheets("Tables").Select
    Range("F7:M35").Select
    Range("F7").Activate
    Selection.Copy

   
'Paste as image (Centered)(3)
    
    insertPoint.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(3).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With

'======== FOURTH TABLE ==========
'Copy contents

    Sheets("Tables").Select
    Range("AB7:AI70").Select
    Range("AB7").Activate
    
    Selection.Copy

'Paste as image (Centered)(4)
    
    insertPoint.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(4).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
    
    
'======== FIFTH TABLE ==========
'Copy contents (5)

    Sheets("Tables").Select
    Range("P7:Z29").Select
    Range("P7").Activate
    Selection.Copy
   
'Paste as image (Centered)(5)
    
    insertPoint.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(5).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
'Insert Addresses and Subject

    With outMail
        .To = Sheets("Setup").Range("B1").Value
        .CC = Sheets("Setup").Range("B2").Value
        .Subject = Sheets("Tables").Range("L1").Value & " " & Sheets("Tables").Range("A2").Value
        
        
        
        .Display
    End With
    

    '======== Credit ==========
'Copy contents (5)

    Sheets("Setup").Select
    Range("AB62").Select
    Range("AB62").Activate
    Selection.Copy
       
       
    Sheets("Tables").Select
    Range("N7").Select
    
'Paste as image (Centered)(5)
    
    insertPoint.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(5).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
    
    
    
'Insert Addresses and Subject

    With outMail
        .To = Sheets("Setup").Range("B1").Value
        .CC = Sheets("Setup").Range("B2").Value
        .Subject = Sheets("Setup").Range("I5").Value & " " & Sheets("Setup").Range("I6").Value
        
        
        
        .Display
    End With
    
    Range("J6").Activate
    
'5 Second Pause

    Application.Wait (Now + TimeValue("00:00:05"))
    
'On Finish White

    Range("N7:O10").Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True

End Sub




Sub Oops()

    MsgBox ("Gotta run refresh first, boss")

End Sub

"Oops" macro at the end locks the Email macro button until the report has been refreshed (combating human err)

The main functions doing the legwork here are the "Copy Contents" and "Paste As Image (Centered)" sections
Where the key differences are in:
-Copy contents selected range
and
-"With wordDoc.Tables(x).Rows" where x is + 1 for each item added, in sequence.

VBA Code: 
'Copy contents

    Sheets("Setup").Select
    Range("H13:K32").Select
    Range("H13").Activate
    Selection.Copy



'Paste as image (Centered)
    
    Dim insertPoint As Object
    wordDoc.Paragraphs.first.Range.InsertParagraphBefore 'Create new empty paragraph before signature
    Set insertPoint = wordDoc.Paragraphs.first
    insertPoint.Range.InsertParagraphBefore 'Create another
    insertPoint.Previous.Range.PasteAndFormat Type:=wdChartPicture
    
    With wordDoc.Tables(1).Rows
        .WrapAroundText = 0 'If this is true does not work
        .Alignment = 1
    End With
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

O
  • Question Question
VBA Email Formatting - Charts and Tables
Replies
0
Views
1K
oddzac
O
M
  • Question Question
Add text before pasting pic in outlook
Replies
2
Views
90
DanteAmor
DanteAmor
C
  • Question Question
Opening Outlook to send and email
Replies
1
Views
461
Trebor76
T
C
  • Question Question
VBA to save file to SharePoint and attach to outlook template saved in SharePoint
Replies
6
Views
282
Chris8630
C
H
  • Question Question
VBA is centering the image instead of aligning it to the left as usual in New Email
Replies
1
Views
215
Micron
M

Forum statistics

Threads
1,224,818
Messages
6,181,151
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top