Excel to PowerPoint VBA - Table Conditional Formatting - excel

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

Answer 1

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