Sub CopyPasteAsUnion()

     Dim sld As Slide
     Dim shp As Shape

     Dim ShapeOne As String
     Dim ShapeTwo As String
     Dim oshpR As ShapeRange


     For Each sld In ActivePresentation.Slides
     ActiveWindow.View.GotoSlide sld.SlideIndex
          For Each shp In sld.Shapes
           If shp.HasTextFrame = True Then
                If shp.TextFrame.HasText = True Then
                      ShapeOne = shp.Name
                      ShapeTwo = shp.Name & "_1"
                      With shp.Duplicate
                         .Left = shp.Left
                         .Top = shp.Top
                         .Name = ShapeTwo
                      End With
                            Set oshpR = sld.Shapes.Range(Array(ShapeOne, ShapeTwo))
                            oshpR.Select
                            CommandBars.ExecuteMso ("ShapesUnion")
                    End If
                End If
         Next
     Next
End Sub

Select all Open in new window

Run-time error '-2147467259(80004005)': Method 'ExecuteMso' of objects '_CommandBars' Failed

Sub ExcelRangeToPowerPoint()
    
        Application.ScreenUpdating = False
        Dim rng As Range
        Dim PowerPointApp As Object
        Dim myPresentation As Object
        Dim mySlide As Object
        Dim myShape As Object
        Dim PPPres As Object
        Dim PPT As PowerPoint.Application
        Dim SlideNum As Integer
        Dim counter As Integer

    Set PPT = New PowerPoint.Application
    PPT.Visible = True
    PPT.Presentations.Open Filename:="C:\Users\Ashkan\Desktop\Powerpoint autoupdate\1.pptm"
    
For counter = 1 To 3
    SlideNum = counter
    Sheets("Sheet" & SlideNum).Select
    'Copy Range from Excel
    Set rng = ThisWorkbook.ActiveSheet.Range("A1:B5")
    rng.Copy
      
    'Paste to PowerPoint and position
      Set myPresentation = PPT.ActivePresentation
      myPresentation.Slides(SlideNum).Shapes.Paste
      
      Set mySlide = myPresentation.Slides(SlideNum)
      Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
        Set position:
          myShape.Left = 128.88
          myShape.Top = 68.4
          
          Set mySlide = Nothing
          
Next counter

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
  
End Sub

Select all Open in new window