Copy Excel Conditional Formatting traffic lights to Powerpoint without pixelated icons?

[lindstroem]

Hello
I have made a scorecard in Excel which I need to paste to Excel on a monthly basis. I would like to adjust the size of the scorecard somewhat in Powerpoint and also use full screen mode which changes the size of the traffic lights. The traffic lights gets pixelated and looks unproffessional

See example.
Do anyone know a work around for this to get the actual symbol from Excel to PowerPoint?

Hope for answers as this has been bugging me for years!

 

[pbornemeier]

Set font size so the copied area will not need to be resized in powerpoint.
Add a helper column with a formula that returns a value that can correspond to the colors of the stoplight.
Write code to add an appropriately colored circle to that column this code should get you started, or provide more info.

Option Explicit

Sub AddShapeBasedOnContent()
    'Select a range  containing numbers 1, 2 ,3
    'Fill cell with a circle 1=red, 2-yellowm 3=Green
    
    Dim rngSelection As Range
    Dim rngCell As Range
    Dim sHeight As Single
    Dim sWidth As Single
    Dim sMinDim As Single
    Dim lGradient1Color As Long
    Dim lGradient2Color As Long
    Dim lLineForeColor As Long
    Dim sOffset As Single
    Dim rngShape As Shape
    
    Set rngSelection = Intersect(Selection, ActiveSheet.UsedRange)
    
    'Erase previously generated shapes
    For Each rngShape In ActiveSheet.Shapes
        If Left(rngShape.Name, 4) = "FSL_" Then rngShape.Delete
    Next
    
    'Set colors for different
    For Each rngCell In rngSelection
        If rngCell.Value = 1 Or rngCell.Value = 2 Or rngCell.Value = 3 Then
            sMinDim = rngCell.Height
            If rngCell.Width < sMinDim Then sMinDim = rngCell.Width
            sMinDim = 0.8 * sMinDim
            sOffset = 0.14 * sMinDim
            Select Case rngCell.Value
            Case 1  'Red
                lGradient1Color = 2302877
                lGradient2Color = 4408319
                lLineForeColor = 128
            Case 2  'Yellow
                lGradient1Color = 13434879
                lGradient2Color = 52479
                lLineForeColor = 5677048
            Case 3  'Green
                lGradient1Color = 3394611
                lGradient2Color = 39168
                lLineForeColor = 32768
            End Select
            
            ActiveSheet.Shapes.AddShape(msoShapeOval, rngCell.Left + sOffset, rngCell.Top + sOffset, sMinDim, sMinDim).Select
            With Selection.ShapeRange.Fill
                .Visible = msoTrue
                .TwoColorGradient msoGradientDiagonalUp, 2
                .GradientStops.Insert lGradient1Color, 0
                .GradientStops.Insert lGradient2Color, 1
                .ForeColor.TintAndShade = 0
                .ForeColor.Brightness = 0
            End With
            With Selection.ShapeRange.Line
                .Visible = msoTrue
                .ForeColor.RGB = lLineForeColor
                .Transparency = 0
                .Weight = 1.5
            End With
            
            Selection.Name = "FSL_" & rngCell.Address(False, False)
            
        End If
        
    Next
    
    Set rngSelection = Nothing
End Sub