Home » excel » Powerpoint VBA Automation Slow when running in excel

Powerpoint VBA Automation Slow when running in excel

Posted by: admin April 23, 2020 Leave a comment

Questions:

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
How to&Answers:

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