Selecting stars with mouse click and totaling

[schefke2002]

Hello Excel experts,

I am trying to complete a task, can someone help?

Here are my requirements:

1. Allow user to select the star rating with a mouse click. They can select up to 5 stars.
2. Display the total number of selected stars under the "Total Stars" column.

I saw this thread and and thought this was a good starting point.

I am a complete macro newbie and have no idea how to modify this code to meet the above requirements *and* insert the macro.

I have attached my file so you can see. If someone could modify the file directly and re post I would be so grateful.

Thank you!

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("H2:L8")) Is Nothing Then
        Range("H2:L8").Rows(Target.Row - 1).Font.ColorIndex = xlAutomatic
        Range("H2:H8").Rows(Target.Row - 1).Resize(1, Target.Column - Range("H2").Column + 1).Font.ColorIndex = 6
    ElseIf Not Intersect(Range("G2:G8"), Target) Is Nothing Then
        ' No stars
        Target.Offset(0, 1).Resize(1, 5).Font.ColorIndex = xlAutomatic
    End If
    
End Sub

[Roger Govier]

Hi

The following code which works when you double click a cell should do the trick.
Double clicking changes the star from black to yellow and vice versa, and either adds or subtracts for the total in column G

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("B22:F50")) Is Nothing Then
    Select Case Target.Row
        Case 32, 33, 45, 46
        Exit Sub
        Case Else
        Target = Chr(171)
        If Target.Font.ColorIndex = 6 Then
            Target.Font.ColorIndex = 0
            Cells(Target.Row, 7) = Cells(Target.Row, 7) - 1
        Else
            Target.Font.ColorIndex = 6
            Cells(Target.Row, 7) = Cells(Target.Row, 7) + 1
        End If
        End Select
    End If
End Sub

[schefke2002]

Hello Roger,

First of all, thank you so much for your reply. This is my first experience with the forum and I'm absolutely thrilled there's experts like yourself out there in cyber space. Regarding the solution, this is almost exactly what I was looking for. A slight tweak would make this perfect. As it is now, the user has to double click each star to turn it yellow. It would be ideal if you could add the following two things:

1) Single click to turn the star yellow
2) When the user clicks one star it turns the previous stars yellow. For example, if the user single-clicked the 4th star then star 1, 2, 3, and 4 would turn yellow. Similarly, if the user single-clicked the 2nd star it would turn star 1 and 2 yellow.

The attached doc demonstrates this well. I just don't know how to integrate this functionality with your VB code.

Thanks a million, really!!!!

[Roger Govier]

Hi

Amending the code to change all cells to the left of the cell chosen is easy enough to achieve.
I am assuming that if you had 4 cells coloured Yellow in a row, and you then clicked on a cell in column C, you would want all cells turned black, not just column B and C, leaving D and E as Yellow

The included code, will now set everything in the row back to black if the selected cell is already Yellow, and will colour all cells up to and including the selected cell as Yellow, if the colour is already Black.

Whatever we do, is going to involve more than 1 click anyway.
There are various events that can be used to trigger off a reaction on a sheet.

Before Double Click - which I chose

Before Right Click - which would mean having to disable the normal right click menu you get when right clicking a cell, and I do not favour

Selection Change - which happens as soon as you select a different cell on the sheet.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

   Dim tc As Long, tr As Long
   If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("B22:F50")) Is Nothing Then
    tc = Target.Column
    tr = Target.Row
    Select Case Target.Row
        Case 32, 33, 45, 46
        Exit Sub
        Case Else
        Target = Chr(171)
        If Target.Font.ColorIndex = 6 Then
            Range(Cells(tr, 2), Cells(tr, 6)).Font.ColorIndex = 0
            Cells(tr, 7) = 0
        Else
            Range(Cells(tr, 2), Cells(tr, tc)).Font.ColorIndex = 6
            Cells(tr, 7) = tc - 1
        End If
        End Select
    End If

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim tc As Long, tr As Long
   If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("B22:F50")) Is Nothing Then
    tc = Target.Column
    tr = Target.Row
    Select Case Target.Row
        Case 32, 33, 45, 46
        Exit Sub
        Case Else
        Target = Chr(171)
        If Target.Font.ColorIndex = 6 Then
            Range(Cells(tr, 2), Cells(tr, 6)).Font.ColorIndex = 0
            Cells(tr, 7) = 0
        Else
            Range(Cells(tr, 2), Cells(tr, tc)).Font.ColorIndex = 6
            Cells(tr, 7) = tc - 1
        End If
        End Select
    End If
End Sub

If we use Selection change, then having moved to a cell, the above events would take place, but you would then need to move to another cell in order to get the change back again.

I personally still favour the double click method, but I have left both enabled in the attached file.
You can either Rem out the block of code you don't want, or delete it.

I hope that this helps