Changing font size within a Shape object (Table) in PowerPoint

I'm trying to change a font size for the Shape object I'm pasting to PowerPoint from Excel. This is a table that looks like this:

I used the way presented in this thread, and it works but the problem is that it works extremely slow:

https://stackoverflow.com/questions/36481106/change-the-font-size-within-a-pasted-shape-in-powerpoint

Any idea how to speed this up? Is there a method that could replicate a behavior of Ctrl + A within a shape and change the font instantly instead of going through each and every cell within a table?

Setting up an array of cells seemed to improve the speed of the macro you are referring to. I tested it with a table with 120 rows and 3 columns and it took one second against the 11 of the one you linked. however, the more I test it, the more various the runtime.

I made two versions, in the first the font size is applied at the end, in the second during the building of the arrays. It took the same amount of time, so it's up to you which one you prefer. I changed the slide index for all three for testing purposes, so you may have to edit that.

Just for reference, I am also posting the code you mentioned.

Original code

Sub changefontsizetablesoriginal()


Dim oShp As Shape
Dim oTbl As Table
Dim l As Long
Dim j As Long
Dim tT As Long

tT = Timer

Set oShp = ActivePresentation.Slides(3).Shapes(1)
Set oTbl = oShp.Table


For i = 1 To oTbl.Rows.Count
For j = 1 To oTbl.Columns.Count
oTbl.Cell(i, j).Shape.TextFrame.TextRange.Font.Size = 12

Next j
Next i
Debug.Print Format(tT, "mm.ss.ssss")
End Sub

Edited code (supposedly faster, based on array of cells)

Sub changeFontSizeInTable()

Dim oSld As PowerPoint.slide
Dim oShp As PowerPoint.Shape
Dim oTbl As PowerPoint.Table
Dim i As Long
Dim j As Long
Dim cellArr() As PowerPoint.Shape
Dim tT As Long

tT = Timer

Set oSld = ActivePresentation.Slides(1)
Set oShp = oSld.Shapes(1)
Set oTbl = oShp.Table


ReDim cellArr(oTbl.Rows.Count, oTbl.Columns.Count)
For i = 1 To oTbl.Rows.Count
For j = 1 To oTbl.Columns.Count


Set cellArr(i, j) = oTbl.Cell(i, j).Shape


Next j
Next i

For i = 1 To oTbl.Rows.Count
For j = 1 To oTbl.Columns.Count

cellArr(i, j).TextFrame.TextRange.Font.Size = 16


Next j
Next i


Debug.Print Format(tT, "mm.ss.ssss")

End Sub

Sub changeFontSizeInTable2()

Dim oSld As PowerPoint.slide
Dim oShp As PowerPoint.Shape
Dim oTbl As PowerPoint.Table
Dim i As Long
Dim j As Long
Dim cellArr() As PowerPoint.Shape
Dim tT As Long

tT = Timer

Set oSld = ActivePresentation.Slides(2)
Set oShp = oSld.Shapes(1)
Set oTbl = oShp.Table

ReDim cellArr(oTbl.Rows.Count, oTbl.Columns.Count)
For i = 1 To oTbl.Rows.Count
For j = 1 To oTbl.Columns.Count

Set cellArr(i, j) = oTbl.Cell(i, j).Shape
cellArr(i, j).TextFrame.TextRange.Font.Size = 12

Next j
Next i

Debug.Print Format(tT, "mm.ss.ssss")

End Sub