Ratings Box with Restricted Access & Auto-fill

[marklongbottom]

What I am after is a way of only allowing users of a spreadsheet to enter either a 1, 2 or 3 (up to 10) in the cells G5:G20 (16cells).
Each of the 16 cells has a product benefit next to it that I want users to rate 1-10. I don't want them to input anything else and I only want them to rate what they believe are the top 10 benefits 1-10 only using 1-10. This means 6 cells/benefits will not get a score and need to default to 0.

So basically Mr Smith will rate one benefit 10, another 9, another 8 and so on. Only using 10 once, 9 once, 8 once etc.
Can the user be restricted to only enter what I want, like this?

 

[MrTomasz]

for 1 to 10 restriction use data validation feature in excel, for the rest this should help (enter it in sheet code, not a module)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Current As Worksheet
    Dim myRange As Range
    Dim cell As Range
    
    Set myRange = ActiveSheet.Range("g5:g20")
    Set isect = Application.Intersect(Target, myRange)
    
    If Not isect Is Nothing And (Target.Value = 0 Or Target.Value = "") Then
        If Application.WorksheetFunction.CountIf(myRange, ">0") = 10 Then
            MsgBox "you already scored 10 rows"
            For Each cell In myRange
                If cell.Value = "" Then cell.Value = "0"
            Next
            ActiveSheet.Range("a1").Select
        End If
    End If
End Sub

 

[marklongbottom]

Thanks for this MrTomasz. It works perfectly.​

 

[marklongbottom]

I do have a modification needed now if someone can help?
The above works for user 1 completing cells G5:G20 but I need it to also work for user 2 completing cells H5:H20 and user 3 completing cells I5:I20. How can I use the above solution for other ranges in the same macro?

 

[marklongbottom]

for 1 to 10 restriction use data validation feature in excel, for the rest this should help (enter it in sheet code, not a module)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Current As Worksheet
    Dim myRange As Range
    Dim cell As Range
   
    Set myRange = ActiveSheet.Range("g5:g20")
    Set isect = Application.Intersect(Target, myRange)
   
    If Not isect Is Nothing And (Target.Value = 0 Or Target.Value = "") Then
        If Application.WorksheetFunction.CountIf(myRange, ">0") = 10 Then
            MsgBox "you already scored 10 rows"
            For Each cell In myRange
                If cell.Value = "" Then cell.Value = "0"
            Next
            ActiveSheet.Range("a1").Select
        End If
    End If
End Sub

Is there a way I can have this code also look at other columns?
The above works for user 1 completing cells G5:G20 but I need it to also work for user 2 completing cells H5:H20 and user 3 completing cells I5:I20. How can I use the above solution for other ranges in the same macro?

 

[MrTomasz]

try:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call check1(ActiveSheet.Range("g5:g20"), Target)
    Call check1(ActiveSheet.Range("h5:h20"), Target)
    Call check1(ActiveSheet.Range("i5:i20"), Target)
End Sub

Sub check1(myRange As Range, Target As Range)
    Dim cell As Range
   
    Set isect = Application.Intersect(Target, myRange)
  
    If Not isect Is Nothing And (Target.Value = 0 Or Target.Value = "") Then
        If Application.WorksheetFunction.CountIf(myRange, ">0") = 10 Then
            MsgBox "you already scored 10 rows"
            For Each cell In myRange
                If cell.Value = "" Then cell.Value = "0"
            Next
            ActiveSheet.Range("a1").Select
        End If
    End If
End Sub

 

[marklongbottom]

try:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call check1(ActiveSheet.Range("g5:g20"), Target)
    Call check1(ActiveSheet.Range("h5:h20"), Target)
    Call check1(ActiveSheet.Range("i5:i20"), Target)
End Sub

Sub check1(myRange As Range, Target As Range)
    Dim cell As Range
  
    Set isect = Application.Intersect(Target, myRange)
 
    If Not isect Is Nothing And (Target.Value = 0 Or Target.Value = "") Then
        If Application.WorksheetFunction.CountIf(myRange, ">0") = 10 Then
            MsgBox "you already scored 10 rows"
            For Each cell In myRange
                If cell.Value = "" Then cell.Value = "0"
            Next
            ActiveSheet.Range("a1").Select
        End If
    End If
End Sub

This is great. Thanks again for your help. It works perfectly although I get the below if I select one of the completed cells after I have clicked ok to the pop-up MsgBox. Is there a way to stop this coming up? I have a bad feeling it'll cause a lot of confusion when users are completing the spreadsheet.

 

[MrTomasz]

this happens when you select multiple cells right? you can avoid this with:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Call check1(ActiveSheet.Range("g5:g20"), Target)
    Call check1(ActiveSheet.Range("h5:h20"), Target)
    Call check1(ActiveSheet.Range("i5:i20"), Target)
End Sub

however due to this, user will be able to avoid your restriction (select more than one cell and type something, this will fill the cell even if the limit sie breached)

 

[marklongbottom]

this happens when you select multiple cells right? you can avoid this with:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Call check1(ActiveSheet.Range("g5:g20"), Target)
    Call check1(ActiveSheet.Range("h5:h20"), Target)
    Call check1(ActiveSheet.Range("i5:i20"), Target)
End Sub

however due to this, user will be able to avoid your restriction (select more than one cell and type something, this will fill the cell even if the limit sie breached)

Ah ok. Thanks for explaining. I might be best leaving it then.