.CopyPicture and paste with 2 ranges

[Akbarov]

Hello community,
I try to automate XL to PPT.
I can transfer single ranges to PPT ( as new slide ) with following method.

  Dim PP As PowerPoint.Application
  Dim PPpres As PowerPoint.Presentation
  Dim PPslide As Object
  Dim PpShape As PowerPoint.Shape
  Dim SlideTitle As String
  Dim SlideNum As Integer
  Dim WSrow As Long
  Dim Sh As Shape
  Dim Rng As Range
  Dim myShape As Object


Set PP = GetObject(class, "PowerPoint.Application")
PP.Visible = True
Set PPpres = PP.Presentations.Open(Filename:="C:\Users\Mac\Desktop\test\PPT.pptx")
'Specify the chart to copy and copy it



Dim k As Long, i As Long
k = 1    '<----- for picture naming

    For i = 6 To Cells(70, Columns.Count).End(xlToLeft).Column Step 10

        With Cells(70, i)
 
           .Resize(1, 10).CopyPicture Appearance:=xlPrinter, Format:=xlPicture    '<---- xlPrinter or xlScreen

 'Wait to make sure computer is ready for next line (a possible problem when working with pictures in excel)
                DoEvents
                DoEvents

                .Offset(150, 0).PasteSpecial

 'Wait to make sure computer is ready for next line (a possible problem when working with pictures in excel)
                DoEvents
                DoEvents
        End With

 'Give the last pasted picture a name.
                ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Name = "Area " & k


Set PPslide = PPpres.Slides.Add(1, 10)
PP.ActiveWindow.View.GotoSlide (1)
Set PPslide = PPpres.Slides(1)
'Paste to PowerPoint and position
PPslide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
 Set myShape = PPslide.Shapes(PPslide.Shapes.Count)
  'Set position:
      myShape.Left = 150
      myShape.Top = 210
      myShape.Height = 540
      myShape.Width = 1800

PP.Visible = True
PP.Activate

Application.CutCopyMode = False

Next i
k = k + 1

Now I want to make some changes and
1) Copy 2 ranges as picture.
2) Give each picture name ( myshape1 , myshape2 )
3) Paste each of them to different positions with different sizes to PPT

I tried to do like below

 For i = 6 To Cells(70, Columns.Count).End(xlToLeft).Column Step 10

       With Cells(70, i)
    .Resize(1, 10).CopyPicture Appearance:=xlPrinter, Format:=xlPicture
                    DoEvents
                   
     'Give the last pasted picture a name.
                ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Name = "Element1" & k
                Set myShape = ActiveSheet.Shapes("Element1" & k)
                    DoEvents
    .Offset(15, 0).PasteSpecial
    Range("B1").CopyPicture Appearance:=xlPrinter, Format:=xlPicture
                    DoEvents
                   
     'Give the last pasted picture a name.
                ActiveSheet.Pictures(ActiveSheet.Pictures.Count).Name = "Element2" & k
                Set myShape1 = ActiveSheet.Shapes("Element2" & k)
                    DoEvents
    .Offset(25, 0).PasteSpecial
End With

But I get error: Unable to get pictures property in worksheet class.

Can anyone tell me what I do wrong?