Copy a range from excel and paste as table in Powerpoint Slide

If you want to copy the range and paste as table in PPT slide. Try this macro -


Method 1 - Using Add table command


Sub export_to_ppt()

'In tools Reference add Microsoft PowerPoint

Dim PPApp           As PowerPoint.Application
Dim PPPres          As PowerPoint.Presentation
Dim PPSlide         As PowerPoint.slide
Dim SlideCount      As Integer
Dim shptbl          As Table


    Set PPApp = New PowerPoint.Application
    PPApp.Visible = True
    'create new ppt
    Set PPPres = PPApp.Presentations.Add
    'count no of slides
    SlideCount = PPPres.Slides.Count
    'set layout of slide
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
    'add header
    PPSlide.Shapes(1).TextFrame.TextRange.Text = Sheets(1).Range("A1").Value

    'format header
    With PPSlide.Shapes(1).TextFrame.TextRange.Characters
        .Font.Size = 30
        .Font.Name = "Arial"
        .Font.Color = vbWhite
    End With
    
    With PPSlide.Shapes(1)
        .Fill.BackColor.RGB = RGB(79, 129, 189)
        .Height = 50
    End With
    ' pass no of rows and columns
    PPSlide.Shapes.AddTable 7, 3
    Set shptbl = PPSlide.Shapes(PPSlide.Shapes.Count).Table
    
    
    For i = 1 To 7
        For j = 1 To 3 ' add data to table from excel
            shptbl.Cell(i, j).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i + 2, j).Value
        Next j
    Next i
   
   Set PPSlide = Nothing
   Set PPPres = Nothing
   Set PPApp = Nothing
   
End Sub

Download Working File

Method 2 - Using using [Pastespecial - Micorosoft Office Excel Worksheet(Code) Object]

Sub export_to_ppt()

'In tools Reference add Microsoft PowerPoint

Dim PPApp           As PowerPoint.Application

Dim PPPres          As PowerPoint.Presentation

Dim PPSlide         As PowerPoint.slide

Dim SlideCount      As Integer

Dim shptbl          As Table

    Set PPApp = New PowerPoint.Application

    PPApp.Visible = True

    'create new ppt

    Set PPPres = PPApp.Presentations.Add

    'count no of slides

    SlideCount = PPPres.Slides.Count

    'set layout of slide

    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)

    'add header

    PPSlide.Shapes(1).TextFrame.TextRange.Text = Sheets(1).Range("A1").Value

    'format header

    With PPSlide.Shapes(1).TextFrame.TextRange.Characters

        .Font.Size = 30

        .Font.Name = "Arial"

        .Font.Color = vbWhite

    End With

    

    With PPSlide.Shapes(1)

        .Fill.BackColor.RGB = RGB(79, 129, 189)

        .Height = 50

    End With

   

    Sheets(1).Range("a3:c9").Copy ' copy the range

    PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex ' activate the slide no

    PPApp.ActiveWindow.View.PasteSpecial ppPasteOLEObject, msoFalse ' paste using pastespecial method

  

    Set PPSlide = Nothing

    Set PPPres = Nothing

    Set PPApp = Nothing

   

End Sub

Download Working File