VBA code to paste data in a Powerpoint table using Excel data keeping Powerpoint font

[ramez75]

Hi,

I have been for few days trying to figure out the on how to copy data from excel to power point keeping power point format. After searching I found how to move charts but I am not successful in adding the appropriate vba code to add the data from excel table to the power point table

Below is what I have so far and it works for moving charts from excel to specific slides in power point. I want to add to the below vba a way to move data from tables in sheet14, sheet13, sheet7, sheet6, sheet5, sheet3. The tables in those sheets are comprised of A2:A6 and I named them Source 1, 2, 3, etc. That is Source1 is from Sheet3, Source2 is from Sheet4, etc. The values in those tables in excel need to be copied and pasted in Power Point in specific slides. For example Source1 from Sheet3 need to be pasted in the table (columns A2 to A6) in slide 23, etc.

Sub PushChartsToPPT()

Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
Dim strpath As String
Dim strfile As String
Dim PPT As PowerPoint.Application
Dim x As Integer
Dim slideNo As Integer
Set PPT = New PowerPoint.Application
PPT.Visible = True
PPT.Presentations.Open "C:\Users\Review.pptx"

'------select the chart to paste and copy it to the clipboard as a picture
    ActiveWorkbook.Worksheets("Sheet1").Select
    ActiveWorkbook.Worksheets("Sheet1").ChartObjects("Chart 14").Select
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    'paste picture to powerpoint and select the associated slide
    slideNo = InputBox("Enter Sheet1 slide Number")
    PPT.ActivePresentation.Slides(slideNo).Shapes.Paste
    PPT.ActivePresentation.Slides(slideNo).Select
    'get total number of shapes in the subject slide and set to variable 'x'
    x = PPT.ActivePresentation.Slides(slideNo).Shapes.Count
    'select the highest numbered shape in the slide (which will be the item that was just pasted)
    PPT.ActivePresentation.Slides(slideNo).Shapes(x).Select
    'center the shape on the slide
    PPT.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPT.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ActiveWorkbook.Worksheets(""Sheet2).Select
    ActiveWorkbook.Worksheets("Sheet2").ChartObjects("Chart 1").Select
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    slideNo = InputBox("Enter  Sheet1slide Number")
    PPT.ActivePresentation.Slides(slideNo).Shapes.Paste
    PPT.ActivePresentation.Slides(slideNo).Select
    x = PPT.ActivePresentation.Slides(slideNo).Shapes.Count
    PPT.ActivePresentation.Slides(slideNo).Shapes(x).Select
    PPT.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPT.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ActiveWorkbook.Worksheets(""Sheet3).Select
    ActiveWorkbook.Worksheets("Sheet3").ChartObjects("Chart 1").Select
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    slideNo = InputBox("Enter  Sheet3slide Number")
    PPT.ActivePresentation.Slides(slideNo).Shapes.Paste
    PPT.ActivePresentation.Slides(slideNo).Select
    x = PPT.ActivePresentation.Slides(slideNo).Shapes.Count
    PPT.ActivePresentation.Slides(slideNo).Shapes(x).Select
    PPT.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPT.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ActiveWorkbook.Worksheets(""Sheet4).Select
    ActiveWorkbook.Worksheets("Sheet4").ChartObjects("Chart 1").Select
    ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    slideNo = InputBox("Enter  Sheet4 slide Number")
    PPT.ActivePresentation.Slides(slideNo).Shapes.Paste
    PPT.ActivePresentation.Slides(slideNo).Select
    x = PPT.ActivePresentation.Slides(slideNo).Shapes.Count
    PPT.ActivePresentation.Slides(slideNo).Shapes(x).Select
    PPT.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPT.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
                            
'------save the presentation 
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
    strpath = .SelectedItems(1)
    End With
    strfile = InputBox("Enter PPT file name")
    PPT.ActivePresentation.SaveAs strpath & "\" & strfile & ".pptx"

'close current presentation
    PPT.ActivePresentation.Close

'Quit PowerPoint
    PPT.Quit

'Clear PowerPoint application variable
Set PPT = Nothing
 
Call sourceSheet.Activate
     
End Sub

So I found the below vba on the forum and it seems to work by itself but it only works if the Power Point file is open and on slide 23. I need the below vba to be added to the above vba but to work without having the power point open and I want to be able to copy tables "Source1" into slide 23, "Source2" into slide 25, "Source3" into slide 28, etc. I have a total of 4 tables

Sub ExporttoPPT()

 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Dim NextShape As Integer
 Dim ActFileName As Variant
 Dim slideNo As Integer
On Error Resume Next
 ActFileName = Sheet3.Range("Source1").Value
 Set PP = CreateObject("Powerpoint.Application")
 PP.Activate
 Set PP_File = PP.Presentations.Open(ActFileName)
 PP.Visible = True
 Range("Source1").Copy
 PP_File.Slides(23).Shapes("Table1").Table.Cell(2, 1).Select
 PP.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault
 
 'PP.ActiveWindow.View.GotoSlide (1)
 Set PP_Slide = Nothing
 Set PP_File = Nothing
 Set PP = Nothing
 'Worksheets(1).Activate
 Application.ScreenUpdating = True
 Application.EnableEvents = True

End Sub

Any guidance on this is greatly appreciated. I hope my explanation is clear

RB