Powerpoint VBA Automation Slow when running in excel - vba

Question

I am using an excel macro to build a table on a power point slide, and it is incredibly slow iterating through cell (about 1-2 second for each cell). Is there a way to make this process go faster? Here is my Code:
Private Function formatTable(shp As PowerPoint.Shape)
Dim i As Byte
Dim j As Byte
Dim k As Byte
Dim tabCol As Byte
With shp.Table
tabCol = .Columns.Count
For i = 1 To .Rows.Count
For j = 1 To tabCol
With .Cell(i, j).Shape
.TextFrame2.TextRange.Font.Bold = msoTrue
Select Case i
Case 1 ' Header Row
.Fill.ForeColor.RGB = RGB(128, 128, 128)
Case 2, 6, 10, 14, 19 'Elements
.Fill.ForeColor.RGB = RGB(192, 192, 192)
Case 23 'Satisfaction
.Fill.ForeColor.RGB = RGB(255, 255, 153)
Case 27, 29, 31 'Future Behaviors
.Fill.ForeColor.RGB = RGB(204, 255, 104)
Case Else
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.TextFrame2.TextRange.Font.Bold = msoFalse
End Select
With .TextFrame2.TextRange.Font
.Name = "Arial"
.Fill.ForeColor.RGB = IIf(i = 1, vbWhite, vbBlack)
.Size = IIf(j <> 1 And i = 1, 7, 8)
End With
.TextFrame.TextRange.ParagraphFormat.Alignment = IIf(j = 1, ppAlignLeft, ppAlignCenter)
End With
With .Cell(i, j)
.Borders(ppBorderBottom).Weight = 1
.Borders(ppBorderTop).Weight = 1
.Borders(ppBorderLeft).Weight = 1
.Borders(ppBorderRight).Weight = 1
End With
Next
Next
End With
End Function

Answer 1

Unfortunately that is the only way that I know of coloring the cells in a table. I.e. via looping. However you can reduce the time drastically :)
Did you notice the Case Else part? That is the majority of the table. So you can actually remove that from the code and color the entire table in one go using the below code
oPPSlide.Shapes(1).Table.Background.Fill.ForeColor.RGB = RGB(255, 255, 255)
and you can remove the Case Else part. So you will have to loop less. In fact, it will drastically reduce the overall time. See this example that I created.
Sub Sample()
Dim oPPApp As New PowerPoint.Application
Dim oPPPrsn As PowerPoint.Presentation
Dim oPPSlide As PowerPoint.Slide
Dim FlName As String
'~~> Change this to the relevant file
FlName = "C:\Users\Siddharth Rout\Documents\MyFile.PPTX"
oPPApp.Visible = True
'~~> Open the relevant powerpoint file
Set oPPPrsn = oPPApp.Presentations.Open(FlName)
'~~> Change this to the relevant slide which has the shape
Set oPPSlide = oPPPrsn.Slides(1)
'~~> Change the background of the table in one go
oPPSlide.Shapes(1).Table.Background.Fill.ForeColor.RGB = RGB(255, 255, 255)
formatTable oPPSlide.Shapes(1)
'
'~~> Rest of the code
'
End Sub
Private Function formatTable(shp As PowerPoint.Shape)
Dim i As Long, j As Long, k As Long, tabCol As Long
With shp.Table
tabCol = .Columns.Count
For i = 1 To .Rows.Count
For j = 1 To tabCol
With .Cell(i, j).Shape
.TextFrame2.TextRange.Font.Bold = msoTrue
Select Case i
Case 1: .Fill.ForeColor.RGB = RGB(128, 128, 128)
Case 2, 6, 10, 14, 19: .Fill.ForeColor.RGB = RGB(192, 192, 192)
Case 23: .Fill.ForeColor.RGB = RGB(255, 255, 153)
Case 27, 29, 31: .Fill.ForeColor.RGB = RGB(204, 255, 104)
' Case Else
' .Fill.ForeColor.RGB = RGB(255, 255, 255)
' .TextFrame2.TextRange.Font.Bold = msoFalse
End Select
With .TextFrame2.TextRange.Font
.Name = "Arial"
.Fill.ForeColor.RGB = IIf(i = 1, vbWhite, vbBlack)
.Size = IIf(j <> 1 And i = 1, 7, 8)
End With
.TextFrame.TextRange.ParagraphFormat.Alignment = IIf(j = 1, 1, 2)
End With
With .Cell(i, j)
.Borders(ppBorderBottom).Weight = 1
.Borders(ppBorderTop).Weight = 1
.Borders(ppBorderLeft).Weight = 1
.Borders(ppBorderRight).Weight = 1
End With
Next
Next
End With
End Function