Hi

Or you could do it with code, this will show five blank stars when
you click on a cell with a value in column A you can then click on the
3rd star to give that cell a 3 star rating which will show as 3 gold
stars.

paste the following code in the This workbook module

Option Explicit
Private Sub Workbook_Open()
Sheet1.RemoveStars
End Sub

then paste this code in the module in sheet1, add a few entries to
column A then give them a rating by selecting them

Option Explicit
Dim ShapeCnt As Long
Dim LCoord, TCoord As Long
Dim Grade, i As Long
Dim Star, Star1, Star2, Star3, Star4, Star5 As Shape

Private Sub Worksheet_Activate()
[B:B].Font.ColorIndex = 2
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

With ActiveSheet

If Target.Column 1 Then
RemoveStars
Exit Sub
End If

If Target.Count 1 Then
RemoveStars
Exit Sub
End If

If Target.Value = "" Then
RemoveStars
Exit Sub
End If

LCoord = Target.Offset(0, 1).Left
TCoord = Target.Offset(0, 1).Top

ShapeCnt = Shapes.Count

If ShapeCnt 0 Then
RemoveStars
AddStars
Else
AddStars
End If

End With

End Sub
Sub RemoveStars()

With ActiveSheet

ShapeCnt = Shapes.Count

If ShapeCnt 0 Then
Shapes.SelectAll
Selection.Delete
End If

End With

End Sub
Sub AddStars()

With ActiveSheet

Set Star1 = Shapes.AddShape(msoShape5pointStar, LCoord, TCoord, 10,
10)
Star1.Name = "Star1"
Star1.OnAction = "Sheet1.ClickStar1"

Set Star2 = Shapes.AddShape(msoShape5pointStar, LCoord + 12, TCoord,
10, 10)
Star2.Name = "Star2"
Star2.OnAction = "Sheet1.ClickStar2"

Set Star3 = Shapes.AddShape(msoShape5pointStar, LCoord + 24, TCoord,
10, 10)
Star3.Name = "Star3"
Star3.OnAction = "Sheet1.ClickStar3"

Set Star4 = Shapes.AddShape(msoShape5pointStar, LCoord + 36, TCoord,
10, 10)
Star4.Name = "Star4"
Star4.OnAction = "Sheet1.ClickStar4"

Set Star5 = Shapes.AddShape(msoShape5pointStar, LCoord + 48, TCoord,
10, 10)
Star5.Name = "Star5"
Star5.OnAction = "Sheet1.ClickStar5"

End With
ColouredStars
End Sub

Sub ColouredStars()

Grade = ActiveCell.Offset(0, 1).Value

For Each Star In ActiveSheet.Shapes
i = Right(Star.Name, 1)
If i <= Grade Then
Star.Fill.PresetGradient msoGradientDiagonalUp, 1,
msoGradientGold
End If
Next Star

End Sub
Sub ClearStars()
For Each Star In ActiveSheet.Shapes
Star.Fill.Solid
Star.Fill.ForeColor.SchemeColor = 9
Next Star
ColouredStars
End Sub
Sub ClickStar1()
ActiveCell.Offset(0, 1).Value = 1
ClearStars
End Sub
Sub ClickStar2()
ActiveCell.Offset(0, 1).Value = 2
ClearStars
End Sub
Sub ClickStar3()
ActiveCell.Offset(0, 1).Value = 3
ClearStars
End Sub
Sub ClickStar4()
ActiveCell.Offset(0, 1).Value = 4
ClearStars
End Sub
Sub ClickStar5()
ActiveCell.Offset(0, 1).Value = 5
ClearStars
End Sub

Hope this is of some use to you

S