エクセルのシートの内容（セル範囲・オートシェイプ・グラフ）を、
開いているパワーポイントのスライドにサクサク貼り付けるマクロ。
複数シート＆複数範囲　を選択すると、
各選択範囲をループして一括で貼り付けます。
お作法完全無視の酷いコードですが共有。
※参照設定でパワーポイントオブジェクトの参照必須です。
Dim yohaku, top_yohaku, mytitle
Dim myrange, mybook, myppt
Dim Tempslide, TempI
Dim mySelections, mySRange
    
'選択範囲をPPTに図として貼り付け
Sub PastePPT_Pic()
    
    Dim PPT As New PowerPoint.Application
    If PPT.Presentations.Count >= 2 Or _
        PPT.Presentations.Count = 0 Then
        MsgBox "貼り付け先のパワーポイントを１つだけ開いて、やり直して下さい", vbCritical
        End
    End If
    
    '説明
    If MsgBox("【開いているPPT】の【選択中のスライド】をコピーして、" & vbCr & vbCr & _
                "【エクセルの選択範囲】を【図として】貼り付けます。" & vbCr & vbCr & vbCr & vbCr & _
                "※複数シート選択すると、一括処理できます。", vbOKCancel) = vbCancel Then End
    
    '設定
    yohaku = Application.InputBox("左右の余白は何ポイント？（初期設定：20）", , 20, , , , , 1)
    If yohaku = False Then End
    top_yohaku = Application.InputBox("上の余白は何ポイント？（初期設定：80）", , 80, , , , , 1)
    If top_yohaku = False Then End
    
    Set mybook = ActiveWorkbook
    
    TempI = 0
    
    '選択シートを後ろから順番に処理する。
    Set mysheets = ActiveWindow.SelectedSheets
    Application.ScreenUpdating = False
    For i = mysheets.Count To 1 Step -1
        mysheets(i).Select
        Set mySelections = Nothing
        Set myrange = Nothing
        one_flg = False
        
        If TypeName(Selection) = "Range" Then
            Set mySelections = Selection.Areas
            Set mySRange = Selection
        ElseIf TypeName(Selection) Like "Chart*" Then
            Set mySelections = Selection.Parent.Parent.ShapeRange
        Else
            Set mySelections = Selection.ShapeRange
        End If
        
        For j = mySelections.Count To 1 Step -1
            Set myrange = mySelections(j)
            If mySelections.Count = 1 Then
                mytitle = ActiveSheet.Name
            Else
                mytitle = ActiveSheet.Name & "_" & j
            End If
            Call PastePPT_Pic_Loop(PPT)
        Next
    Next
    
    Tempslide.Select
    
    'コピー元を選択しなおす
    If TypeName(mySelections(1)) = "Range" Then
        mySRange.Select
    ElseIf TypeName(mySelections(1)) Like "Chart*" Then
        mySelections(1).Select
    Else
        For Each myselect In mySelections
            myselect.Select False
        Next
    End If
    Application.ScreenUpdating = True
End Sub

'現在のスライド選択するテスト
Sub test_getslide()
    Dim PPT As New PowerPoint.Application
    Set piyobook = ActiveWorkbook
    For i = 1 To 100
        Set Tempslide = Nothing
        piyobook.Activate
        PPT.Activate
        'テンプレスライド
        Do While TypeName(Tempslide) = "Empty" Or TypeName(Tempslide) = "Nothing"
            Sleep 100
            Set Tempslide = PPT.Windows(1).Selection.SlideRange
            Debug.Print i, Tempslide.Name
        Loop
    Next
End Sub

Private Sub PastePPT_Pic_Loop(PPT)
    Set myppt = PPT.Presentations(1)
    
    '貼り付け=======================================
    myrange.Select
    myrange.Copy
    
    PPT.Activate
    '選択中のスライドをテンプレスライドとする。
    TempI = PPT.Windows(1).Selection.SlideRange.SlideIndex
    Set Tempslide = PPT.ActivePresentation.Slides(TempI)
    
    '貼り付けスライド挿入
    Tempslide.Duplicate.MoveTo topos:=TempI + 1
    Set myslide = PPT.ActivePresentation.Slides(TempI + 1)
    swidth = myslide.CustomLayout.Width
    sheight = myslide.CustomLayout.Height - 5
    myslide.Select
    
    With myslide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)(1)
        .LockAspectRatio = True
        .Top = top_yohaku
        If (sheight - top_yohaku) < .Height Then .Height = (sheight - top_yohaku)
        If (swidth - (yohaku * 2)) < .Width Then
            .Width = swidth - (yohaku * 2)
            .Left = yohaku
        Else
            .Left = (swidth - .Width) / 2
        End If
    End With
    myslide.Shapes.title.TextFrame.TextRange.Text = mytitle

    Application.CutCopyMode = False
End Sub