Excel to PowerPoint VBA - Table Conditional Formatting

Question

I'm relatively new to VBA.

I'm helping an internal team to improve workflow by reducing errors when copying and pasting data from Excel to PowerPoint.

How do I configure conditional formatting in the PowerPoint table based on two rules?

2-Color Scale:
Icon Set:

My current code is as follows. This has allowed for data to be copied from a single Excel cell to a single PowerPoint table cell.

Sub TableData()
    Dim oPPApp As Object, oPPrsn As Object, oPPSlide As Object
    Dim oPPShape As Object
    Dim FlName As String
    
    FlName = "FILE PATH"
    
    On Error Resume Next
    Set oPPApp = GetObject(, "PowerPoint.Application")
    
    If Err.Number <> 0 Then
        Set oPPApp = CreateObject("PowerPoint.Application")
    End If
    Err.Clear
    On Error GoTo 0
    
    oPPApp.Visible = True

    Set oPPrsn = oPPApp.Presentations.Open(FlName)

    Set oPPSlide = oPPrsn.Slides(1)
        
        Set oPPShape = oPPSlide.Shapes(2)
        ThisWorkbook.Sheets("Sheet1").Activate
        oPPShape.Table.Cell(2, 3).Shape.TextFrame.TextRange.Text = Range("C1").Value

End Sub

PowerPoint tables don't have conditional formatting, so you would have to rewrite each conditional format as VBA code and apply that to each cell into which you have pasted data. It would be much simply to just paste the Excel table as a picture or other format that preserves the original Excel look, instead of reproducing it in a PowerPoint table. — John Korchok, Oct 27 '22 at 18:00

Oran G. Utan · Answer 1 · 2022-11-23T17:48:57.037

For the table creation, the code is based on this answer I received, so you may have to adjust the code to your liking (it creates a slide for each row), the dimensions of the source and target table are based on my needs, since your code works only for one cell I wanted to test with more data.

The relevant part for your request is anyway this one:

Dim RGB_Val As String

RGB_Val = rng(i).DisplayFormat.Interior.Color
newTable.cell(i, 2).Shape.Fill.ForeColor.RGB = RGB_Val

that takes the background color of Conditionally Formatted cells (so you would have to apply conditional formatting to the Excel table, first) (information gathered from this answer and this one taking care of the comment Jun 9, 2018 at 13:08).

In each slide created following the row, each Excel column cell will then become a row in PPT, on the second column, while on the first there will be the circles, whose size can be defined by FlowRatio's value.

Their colors will have to be defined as per below (values and colors taken from your screenshot):

If rng(i).Value >= 12 Then

ElseIf rng(i).Value < 12 And rng(i).Value >= -12 Then

ElseIf rng(i).Value < -12 Then

So, from this:

you will get this:

but as per above, you may have to adjust sizes of the ranges to avoid errors.

Ah, it runs from Excel to PPT.

Sub CopyConditionalFormattingAddChecks()

Dim DataRange As Range, DataRow As Range, rng As Range, i As Long, col As Long
Dim ppApp As PowerPoint.Application, pres As PowerPoint.Presentation
Dim sld As PowerPoint.slide, newTable As PowerPoint.Table, Sldss As Slides

Dim CellLeft As Single
Dim CellTop As Single
Dim CellWidth As Single
Dim CellHeight As Single
Dim CellWidth_2 As Single

    
Dim Shp_Cntr As Single
Dim Shp_Mid As Single

Dim CircleCheck As PowerPoint.Shape
Dim IconNavigator As Object


Dim RGB_Val As String

Dim SlideCounter As Integer
Dim FlowCounter As Integer
Dim IconCounter As Integer

Dim TestCounter As Integer

FlowRatio = 0.6

    On Error Resume Next
    Set ppApp = GetObject(, "PowerPoint.Application")
    Set pres = ppApp.ActivePresentation
    On Error GoTo 0

    If pres Is Nothing Then
        MsgBox "Destination presentation must be open in PowerPoint", vbCritical
        Exit Sub
    End If
  
  
SlideCounter = 0
CircleCheckCounter = 0
  
  Set DataRange = Selection
    For Each DataRow In DataRange.Rows
        Set sld = pres.Slides.AddSlide(pres.Slides.Count + 1, pres.SlideMaster.CustomLayouts(2))


SlideCounter = SlideCounter + 1
                    
    Set newTable = sld.Shapes.AddTable(14, 4).Table ' different here
    With newTable.Columns(1): .Width = 5: End With
    With newTable.Columns(2): .Width = 60: End With
    With newTable.Columns(3): .Width = 5: End With
    With newTable.Columns(4): .Width = 50: End With
    With sld.Shapes.Placeholders(2): .Width = 550: End With
       
        
    Set rng = DataRow.Cells(1).Resize(1, 10)


    For i = 1 To newTable.Rows.Count
    
    newTable.cell(i, 2).Shape.TextFrame2.TextRange.Text = rng.Cells(i).Value
    
    RGB_Val = rng(i).DisplayFormat.Interior.Color

    newTable.cell(i, 2).Shape.Fill.ForeColor.RGB = RGB_Val
                      

    If rng(i).Value >= 12 Then


        CellTop = newTable.cell(i, 1).Shape.Top
        CellLeft = newTable.cell(i, 1).Shape.Left
        CellWidth = newTable.cell(i, 1).Shape.Width
        CellHeight = newTable.cell(i, 1).Shape.Height
    
        Shp_Cntr = CellLeft + CellWidth / 2
        Shp_Mid = CellTop + CellHeight / 2
    
        Set CircleCheck = sld.Shapes.AddShape(Type:=msoShapeOval, Left:=Shp_Cntr - (CellHeight * FlowRatio / 2), Top:=Shp_Mid - (CellHeight * FlowRatio / 2), Width:=CellHeight * FlowRatio, Height:=CellHeight * FlowRatio)
    
        CircleCheck.Fill.ForeColor.RGB = RGB(214, 85, 50)
        CircleCheck.Line.Weight = 0.75
        CircleCheck.Line.ForeColor.RGB = RGB(255, 255, 255)
        CircleCheck.Line.Visible = msoTrue
        CircleCheck.LockAspectRatio = msoTrue
        CircleCheck.Name = "CircleCheck " & CircleCheckCounter
        CircleCheck.ZOrder msoBringToFront
    
    ElseIf rng(i).Value < 12 And rng(i).Value >= -12 Then


        CellTop = newTable.cell(i, 1).Shape.Top:
        CellLeft = newTable.cell(i, 1).Shape.Left
        CellWidth = newTable.cell(i, 1).Shape.Width
        CellHeight = newTable.cell(i, 1).Shape.Height
        
        Shp_Cntr = CellLeft + CellWidth / 2
        Shp_Mid = CellTop + CellHeight / 2
'
    Set CircleCheck = sld.Shapes.AddShape(Type:=msoShapeOval, Left:=Shp_Cntr - (CellHeight * FlowRatio / 2), Top:=Shp_Mid - (CellHeight * FlowRatio / 2), Width:=CellHeight * FlowRatio, Height:=CellHeight * FlowRatio)

        CircleCheck.Fill.ForeColor.RGB = RGB(234, 194, 130)
        CircleCheck.Line.Weight = 0.75
        CircleCheck.Line.ForeColor.RGB = RGB(255, 255, 255)
        CircleCheck.Line.Visible = msoTrue
        CircleCheck.LockAspectRatio = msoTrue
        CircleCheck.Name = "CircleCheck " & CircleCheckCounter
        CircleCheck.ZOrder msoBringToFront
        
                    
    ElseIf rng(i).Value < -12 Then

        CellTop = newTable.cell(i, 1).Shape.Top:
        CellLeft = newTable.cell(i, 1).Shape.Left
        CellWidth = newTable.cell(i, 1).Shape.Width
        CellHeight = newTable.cell(i, 1).Shape.Height
        
        Shp_Cntr = CellLeft + CellWidth / 2
        Shp_Mid = CellTop + CellHeight / 2

        Set CircleCheck = sld.Shapes.AddShape(Type:=msoShapeOval, Left:=Shp_Cntr - (CellHeight * FlowRatio / 2), Top:=Shp_Mid - (CellHeight * FlowRatio / 2), Width:=CellHeight * FlowRatio, Height:=CellHeight * FlowRatio)

        CircleCheck.Fill.ForeColor.RGB = RGB(104, 164, 144)
        CircleCheck.Line.Weight = 0.75
        CircleCheck.Line.ForeColor.RGB = RGB(255, 255, 255)
        CircleCheck.Line.Visible = msoTrue
        CircleCheck.LockAspectRatio = msoTrue
        CircleCheck.Name = "CircleCheck " & CircleCheckCounter
        CircleCheck.ZOrder msoBringToFront
                  
            End If

        Next i
  
    Next DataRow

End Sub

Excel to PowerPoint VBA - Table Conditional Formatting

1 Answers1