Update existing tables in PowerPoint with VBA code

Question

I have an open Excel file as well as an open PowerPoint file. I want to select and copy two different ranges in Excel (range1: B4:D9, range 2: F4:H10") into two shapes (tables) in my PowerPoint (range1 into Shape 16, range2 into Shape 20).

When I run the subs for range1 and range2 in debug mode after each other the data is pasted correctly in PowerPoint.
When I create one button for each range and use the button to execute the code it also works.

I would like to use the following code to call both codes for range1 and range2 to create only one button for this.
When I run the sub below (UpdateSlide) it pastes range F4:H10 into both Shapes 16 & 20.

Sub UpdateSlide()

    Call range1
    Call range2

End Sub

Code for range1 as well as range2:

Sub range1()

    'Range1 in Excel
    Dim range1 As Excel.range
    Dim sheet As Excel.Worksheet
    Dim excelApp As Excel.Application
    Set excelApp = GetObject(, "Excel.Application")
    Set sheet = excelApp.ActiveWorkbook.Sheets("Sheet1")

    sheet.Activate
    Set range1 = sheet.range("B4:D9")
    range1.Select
    range1.Copy

    'Tabelle in Powerpoint auswählen
    Dim table1 As Powerpoint.Shape
    Dim pptApp As Powerpoint.Application
    Set pptApp = GetObject(, "Powerpoint.Application")
    pptApp.Activate

    Dim slide As Powerpoint.slide
    Set slide = pptApp.ActiveWindow.View.slide
    Set table1 = slide.Shapes(16)
    table1.table.Cell(1, 1).Select

    'Daten einkopieren - ohne das Format verändert wird
    pptApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"

    sheet.Activate

    Set range1 = Nothing
    Set sheet = Nothing
    Set excelApp = Nothing
    Set table1 = Nothing
    Set pptApp = Nothing
    Set slide = Nothing

End Sub


Sub range2()

    'Range2 in Excel
    Dim range2 As Excel.range
    Dim sheet As Excel.Worksheet
    Dim excelApp As Excel.Application
    Set excelApp = GetObject(, "Excel.Application")
    Set sheet = excelApp.ActiveWorkbook.Sheets("Sheet1")

    sheet.Activate
    Set range2 = sheet.range("F4:H10")
    range2.Select
    range2.Copy

    'Tabelle in Powerpoint auswählen
    Dim table2 As Powerpoint.Shape
    Dim pptApp As Powerpoint.Application
    Set pptApp = GetObject(, "Powerpoint.Application")
    pptApp.Activate

    Dim slide As Powerpoint.slide
    Set slide = pptApp.ActiveWindow.View.slide
    Set table2 = slide.Shapes(20)
    table2.table.Cell(1, 1).Select

    'Daten einkopieren - ohne das Format verändert wird
    pptApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"

    Set range2 = Nothing
    Set sheet = Nothing
    Set excelApp = Nothing
    Set table2 = Nothing
    Set pptApp = Nothing
    Set slide = Nothing

End Sub

score 0 · Answer 1 · answered Mar 19 '23 at 14:40

I removed all .Select and .Activate as they are not needed (and actually slow down the macro - please see this as well -)

I would say that in the way you were pasting, the second routine was overwriting the first. I modified your code so that it pastes the correct range at each loop. I also removed the reference to the shape number, I tested it and it ran without issues.

Sub range1()

'Range1 in Excel
Dim range1 As Excel.Range
Dim sheet As Excel.Worksheet
Dim excelApp As Excel.Application
Set excelApp = GetObject(, "Excel.Application")
Set sheet = excelApp.ActiveWorkbook.Sheets("Sheet1")


'Tabelle in Powerpoint auswählen
Dim table1 As PowerPoint.Shape
Dim pptApp As PowerPoint.Application
Set pptApp = GetObject(, "Powerpoint.Application")
'pptApp.Activate

Dim slide As PowerPoint.slide
Set slide = pptApp.ActiveWindow.View.slide

'sheet.Activate
Set range1 = sheet.Range("B4:D9")
'range1.Select
range1.Copy
slide.Shapes.Paste 'This is were I modified your code


End Sub

Sub range2()

'Range2 in Excel
Dim range2 As Excel.Range
Dim sheet As Excel.Worksheet
Dim excelApp As Excel.Application
Set excelApp = GetObject(, "Excel.Application")
Set sheet = excelApp.ActiveWorkbook.Sheets("Sheet1")



'Tabelle in Powerpoint auswählen
Dim table2 As PowerPoint.Shape
Dim pptApp As PowerPoint.Application
Set pptApp = GetObject(, "Powerpoint.Application")

Dim slide As PowerPoint.slide
Set slide = pptApp.ActiveWindow.View.slide

Set range2 = sheet.Range("F4:H10")

range2.Copy

slide.Shapes.Paste 'This is were I modified your code


Set range2 = Nothing
Set sheet = Nothing
Set excelApp = Nothing
Set table2 = Nothing
Set pptApp = Nothing
Set slide = Nothing

End Sub



Sub UpdateSlide()

Call range1
Call range2

End Sub

Update existing tables in PowerPoint with VBA code

1 Answers1