VBA To copy multiple excel range and Paste it on the same slide with positioning

Sumit_123

New Member
Joined
Oct 5, 2021
Messages
16
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hi all, I need some assistance with VBA copy paste from Excel to PowerPoint. I am completely new to this, hope you can help me with this.
Scenario is - I have 6 different excel range (these are excel range and not tables) on one worksheet of excel (as shown in below picture). I want to copy these and paste it into existing Power point which is saved in my system. The way I want to paste it is 2 tables on one slide - which means there will be total of three slides in my PPT.
excel range.PNG

I tried codes here and there which allows me to achieve some part of it but not all of it. The hardest part is to position all those ranges in a specific way in PowerPoint. I want it in this way -

slide eg.PNG


This is the code I tried-

VBA Code:
Sub excelrangetopowerpoint_month()
    Dim powerpointapp As Object
    Set powerpointapp = CreateObject("powerpoint.application")


    Dim destinationPPT As String
    destinationPPT = ("FILE LOCATION")

    On Error GoTo ERR_PPOPEN
    Dim mypresentation As Object
    Set mypresentation = powerpointapp.Presentations.Open(destinationPPT)
    On Error GoTo 0

    Application.ScreenUpdating = False

    PasteToSlide mypresentation.Slides(1), Worksheets("Output (2)").Range("B6:T31")
   
    PasteToSlide mypresentation.Slides(2), Worksheets("Output (2)").Range("B32:T51")
   
    PasteToSlide mypresentation.Slides(3), Worksheets("Output (2)").Range("B54:T66")
  
   
    'duplicate this line for all slides/ranges
    'PasteToSlide mypresentation.Slides(2), Worksheets("objectives").Range("m2")

    powerpointapp.Visible = True
    powerpointapp.Activate

    Application.CutCopyMode = False

ERR_PPOPEN:
    Application.ScreenUpdating = True 'don't forget to turn it on!
    If Err.Number <> 0 Then
        MsgBox "Failed to open " & destinationPPT, vbCritical
    End If
   

End Sub

    Private Sub PasteToSlide(mySlide As Object, rng As Range)
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = enhanced metafile

Dim myShape As Object
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

myShape.Left = 152
myShape.Top = 152
End Sub





Thanks a ton in advance for the help!
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

Forum statistics

Threads
1,224,820
Messages
6,181,160
Members
453,021
Latest member
Justyna P

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