VBA Copying pivot table to powerpoint slide

mjohnston0209

New Member
Joined
Nov 6, 2017
Messages
46
I am working on a macro that will transfer several objects from a specific sheet (sheet2) in excel and onto a specific slide in PowerPoint. I watched a very informative video on how to do this. The objects copied in the video were a range, table, and chart. This all works for me. However, I also need to copy pivot tables.

Below is the code I am currently using. I need to add pivot table coding to two areas. One is under 'Create array to house objects we want to export' and the other is under 'Depending on the object type, copy it a certain way'.

Any help would be greatly appreciated!

VBA Code:
Sub CopyObject()

'Declare PowerPoint Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape

'Declare Excel Variables
Dim ExcObj, ObjType, ObjArray As Variant
Dim LefArray, TopArray, HgtArray, WidArray As Variant
Dim x As Integer

'Open Instance of PowerPoint
Set PPTApp = New PowerPoint.Application
    PPTApp.Visible = True
    PPTApp.Presentations.Open "C:\Users\mjohnston\Desktop\Presentation1.pptx"
    PPTApp.Activate

'Create a reference to the slide we want to work with and delete all shapes on slide
Set PPTSlide = PPTApp.ActivePresentation.Slides(2)

TotalShapes = PPTSlide.Shapes.Count

    For i = TotalShapes To 1 Step -1

    If PPTSlide.Shapes(i).Type <> msoTextBox Then PPTSlide.Shapes(i).Delete
    
    Next i

'Create array to house objects we want to export
ObjArray = Array(Sheet2.Range("B2:D5"), Sheet2.ChartObjects(1), Sheet2.ListObjects(1))

'Define my dimesnion arrays
LefArray = Array(59.3)
TopArray = Array(270)
HgtArray = Array(105.27)
WidArray = Array(359.23)

'Loop through the object array and copy each object

For x = LBound(ObjArray) To UBound(ObjArray)

    'Determine Object Type
    ObjType = TypeName(ObjArray(x))
    
    'Depending on the object type, copy it a certain way
    Select Case ObjType
    
        Case "Range"
            Set ExcObj = ObjArray(x)
                ExcObj.Copy
                
        Case "ChartObject"
            Set ExcObj = ObjArray(x)
                ExcObj.Chart.ChartArea.Copy
                
        Case "ListObject"
            Set ExcObj = ObjArray(x)
                ExcObj.Range.Copy
    
    End Select

    'Pause the Excel Application
    Application.Wait Now() + #12:00:01 AM#
    
    'Past the object in the slide
    PPTSlide.Shapes.PasteSpecial DataType:=ppPasteOleOjbect
    
    'Set a reference to the shape
    Set PPTShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
    
    'Set the dimension of my shape
    With PPTShape
        .Left = LefArray(x)
        .Height = HgtArray(x)
        .Width = WidArray(x)
        .Top = TopArray(x)
            
    End With

Next

End Sub
 

Some videos you may like

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand

smozgur

BatCoder
Joined
Feb 28, 2002
Messages
1,357
Object definition: PivotTables() collection object.
VBA Code:
'Create array to house objects we want to export
ObjArray = Array(Sheet2.Range("B2:D5"), Sheet2.ChartObjects(1), Sheet2.ListObjects(1), Sheet2.PivotTables(1))

Copying the range: TableRange1 or TableRange2 properties.
VBA Code:
Case "PivotTable"
    Set ExcObj = ObjArray(x)
        ExcObj.TableRange1.Copy

Good article about Referencing Pivot Table Ranges in VBA.
 
Solution

mjohnston0209

New Member
Joined
Nov 6, 2017
Messages
46
Object definition: PivotTables() collection object.
VBA Code:
'Create array to house objects we want to export
ObjArray = Array(Sheet2.Range("B2:D5"), Sheet2.ChartObjects(1), Sheet2.ListObjects(1), Sheet2.PivotTables(1))

Copying the range: TableRange1 or TableRange2 properties.
VBA Code:
Case "PivotTable"
    Set ExcObj = ObjArray(x)
        ExcObj.TableRange1.Copy

Good article about Referencing Pivot Table Ranges in VBA.
Works perfectly! Exactly like I wanted.

Any advice on the graphs in the separate post? If not, no worries and thanks again.
 

smozgur

BatCoder
Joined
Feb 28, 2002
Messages
1,357

ADVERTISEMENT

What is the difference between the range image you posted in the first post and the additional post? Do you want me to change the image in the first post and remove your second post, so it would look "no answer" yet?
 

mjohnston0209

New Member
Joined
Nov 6, 2017
Messages
46
What is the difference between the range image you posted in the first post and the additional post? Do you want me to change the image in the first post and remove your second post, so it would look "no answer" yet?
I realized that I didn't screenshot the entire screen (show the row and column headers) in my first post. I always find it easier when I see the cells the data is captured in. That is why I added the second post. I couldn't figure out how to add the additional screenshot to my first post. Then I saw the second post makes it look as if it the thread was answered. Can you remove it?
 

smozgur

BatCoder
Joined
Feb 28, 2002
Messages
1,357

ADVERTISEMENT

Can you remove it?
(y)

 

mjohnston0209

New Member
Joined
Nov 6, 2017
Messages
46
(y)


Tried to message you, but the system wouldn't allow it. Interested in another thread?

Hope all is well.
 
Last edited by a moderator:

mjohnston0209

New Member
Joined
Nov 6, 2017
Messages
46
Object definition: PivotTables() collection object.
VBA Code:
'Create array to house objects we want to export
ObjArray = Array(Sheet2.Range("B2:D5"), Sheet2.ChartObjects(1), Sheet2.ListObjects(1), Sheet2.PivotTables(1))

Copying the range: TableRange1 or TableRange2 properties.
VBA Code:
Case "PivotTable"
    Set ExcObj = ObjArray(x)
        ExcObj.TableRange1.Copy

Good article about Referencing Pivot Table Ranges in VBA.
Any chance you can look at this thread?

Use VBA to enter a varying range of bullet points into body of email
 

Watch MrExcel Video

Forum statistics

Threads
1,127,911
Messages
5,627,594
Members
416,255
Latest member
amethystia

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
Top