MAcro to paste excel table into PPT slide automatically

Hi MikeTron and Sameeru,

this file is unprotected.

or you can use this code.

CreatePPT - Button 1
CreatePPT2 -Button 2
CreatePPT3- Button 3

Sub CreatePPT()
    Dim PPApp As PowerPoint.Application
    Dim PPSlide As PowerPoint.Slide
    Dim SheetName As String
    Dim RangePasteType As String
    Dim shp As Shape
    Dim shps As Shapes
    Dim RangeName1, RangeName2 As String

    SheetName = ActiveSheet.Name ' Both the tables are in same worksheet
    RangeName1 = "A2:H50"
    RangeName2 = "A2:H50"
 
    If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
    If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add
    PPApp.Visible = True
 
    'Set first slide
    '//Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
 
    Worksheets(SheetName).Range("A2:H15").Copy
   
 
    Set PPSlide = PPApp.ActivePresentation.Slides.Add(PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank)
    Worksheets(SheetName).Range("A2:H17").Copy
   With PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
       .Align msoAlignCenters, True
       .Align msoAlignMiddles, True
       .Item(1).ScaleHeight 1, msoCTrue, msoScaleFromMiddle

   End With

    AppActivate ("Microsoft Powerpoint")
    'Clean up
    Set PPSlide = Nothing
    Set PPApp = Nothing
End Sub
Sub CreatePPT2()

    Dim PPApp As PowerPoint.Application
    Dim PPSlide As PowerPoint.Slide
    Dim SheetName As String
    Dim RangePasteType As String
    Dim shp As Shape
    Dim shps As Shapes
    Dim RangeName1, RangeName2 As String

    SheetName = ActiveSheet.Name ' Both the tables are in same worksheet
    RangeName1 = "A2:H50"
    RangeName2 = "A2:H50"
 
    If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
    If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add
    PPApp.Visible = True
 
    'Set first slide
    '//Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
 
    Worksheets(SheetName).Range("A2:H15").Copy
   
 
    Set PPSlide = PPApp.ActivePresentation.Slides.Add(PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank)
    Worksheets(SheetName).Range("A18:H32").Copy
   With PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
       .Align msoAlignCenters, True
       .Align msoAlignMiddles, True
       .Item(1).ScaleHeight 1, msoCTrue, msoScaleFromMiddle

   End With

    AppActivate ("Microsoft Powerpoint")
    'Clean up
    Set PPSlide = Nothing
    Set PPApp = Nothing
End Sub
Sub CreatePPT3()

    Dim PPApp As PowerPoint.Application
    Dim PPSlide As PowerPoint.Slide
    Dim SheetName As String
    Dim RangePasteType As String
    Dim shp As Shape
    Dim shps As Shapes
    Dim RangeName1, RangeName2 As String

    SheetName = ActiveSheet.Name ' Both the tables are in same worksheet
    RangeName1 = "A2:H50"
    RangeName2 = "A2:H50"
 
    If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
    If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add
    PPApp.Visible = True
 
    'Set first slide
    '//Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
 
    Worksheets(SheetName).Range("A2:H15").Copy
   
 
    Set PPSlide = PPApp.ActivePresentation.Slides.Add(PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank)
    Worksheets(SheetName).Range("A33:H51").Copy
   With PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
       .Align msoAlignCenters, True
       .Align msoAlignMiddles, True
       .Item(1).ScaleHeight 1, msoCTrue, msoScaleFromMiddle

   End With

    AppActivate ("Microsoft Powerpoint")
    'Clean up
    Set PPSlide = Nothing
    Set PPApp = Nothing
End Sub