how to crerat star rating in a cell

[Guest]

i need in excel cell value change in star rating like windows media player
rating ( like 5 star change the value depent colour changes)

 

[Guest]

Use CHAR(182) with the Wingdings font.

 

[Dave Peterson]

Just to add to Gary''s Student's response.

If you put the number in a separate cell (say A1), you can use a formula like:

=REPT(CHAR(182),A1)
(still formatted with Wingdings)

This actually displays multiple stars.

If you want to format each star (character by character, no half stars), you
can't use a formula and you have to select the characters in the formula bar,
then format|cells and change the font color.

 

[Incidental]

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