Multiple VBAs on a worksheet.

[Worksong]

Hello, I'm setting a worksheet to score likert-scale (responses from 0-3, 1-5, etc.) questionnaires. I've been able to get code working to have one range of cells return the appropriate value when clicked (and 0 when clicked a second time), but haven't been able to get code for multiple columns to work. For example, for a worksheet that has three columns, one each for responses from 1-3, the code for the "1" column is:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim myTarget As Range
Dim NewVal As Single

Set myTarget = Range("D15:D34")
If Selection.Cells.Count = 1 Then
If Not Intersect(Target, myTarget) Is Nothing Then
Select Case Target.Value
Case 0: NewVal = 1
Case 1: NewVal = 0
Case Else: NewVal = Target.Value
End Select
Target.Value = NewVal
End If
End If
End Sub


This works as expected. I want to add two more target ranges: E15:E34 to return 2 when clicked, and F15:F34 to return 3 when clicked. I've tried a few variations of adding in lines of code for the second (E15:E34, returns "2" or 0), but none have worked thus far. I'm not sure where my syntax is going wrong. Any help is appreciated! (Eventually I want each row to have each row only allow one response, but one thing at a time.)

 

[Worksong]

 

[kevin9999]

Please try the following on a copy of your workbook:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.CountLarge = 1 And Not Intersect(Range("D15:F34"), Target) Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        
        Select Case Target.Column
            Case Is = 4: Target = 1 - Target
            Case Is = 5: Target = 2 - Target
            Case Is = 6: Target = 3 - Target
        End Select
    
    End If
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
End Sub

 

[Worksong]

Please try the following on a copy of your workbook:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Cells.CountLarge = 1 And Not Intersect(Range("D15:F34"), Target) Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
       
        Select Case Target.Column
            Case Is = 4: Target = 1 - Target
            Case Is = 5: Target = 2 - Target
            Case Is = 6: Target = 3 - Target
        End Select
   
    End If
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
End Sub

Thanks Kevin9999! Works like a charm.

 

[kevin9999]

Happy to help, and welcome to the board

 

[Worksong]

I do have a question - if there's another functionality I want this worksheet's code to have, should I continue in this thread or start a new one? Thanks!

 

[Worksong]

Happy to help, and welcome to the board

I do have a question - if there's another functionality I want this worksheet's code to have, should I continue in this thread or start a new one? Thanks!

 

[kevin9999]

If it's a minor adjustment/addition to the code then you can ask it here- otherwise a new thread.

 

[Worksong]

If it's a minor adjustment/addition to the code then you can ask it here- otherwise a new thread.

OK sounds good, thanks.

 

[Worksong]

I adapted the code for a separate worksheet in which some rows are scored forwards and some in reverse: columns E-H return 3-0, respectively, in the forward condition, E=3, F=2, etc.; while the reverse rows return 0-3, E=0, F=1, etc. I've been able to successfully adapt the above code for one condition or the other, but not both. I'm not sure where I'm going wrong.

Forward condition:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge = 1 And Not
Intersect(Range(“E15:H18,E20:H23,E25:H30,E32:H35,E37:H38,E40:H45,E47:H49,E51:H55,E57:H59,E62:H65,E67:H70,E72:H74,E76:H80,E82:H84,E86:H89,E91:H93”), Target) Is Nothing Then
On Error GoTo Escape
Application.EnableEvents = False

Select Case Target.Column
Case Is = 5: Target = 3 - Target
Case Is = 6: Target = 2 - Target
Case Is = 7: Target = 1 - Target
Case Is = 8: Target = 0 - Target
End Select

End If
Continue:
Application.EnableEvents = True
Exit Sub

Escape:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Continue
End Sub



Reverse Condition:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.CountLarge = 1 And Not
Intersect(Range(“E14:H14,E19:H19,E24:H24,E31:H31,E36:H36,E39:H39,E46:H46,E50:H50,E56:H56,E60:H61,E66:H66,E71:H71,E75:H75,E81:H81,E85:H85,E90:H90”), Target) Is Nothing Then
On Error GoTo Escape
Application.EnableEvents = False

Select Case Target.Column
Case Is = 5: Target = 0 - Target
Case Is = 6: Target = 1 - Target
Case Is = 7: Target = 2 - Target
Case Is = 8: Target = 3 - Target
End Select

End If
Continue:
Application.EnableEvents = True
Exit Sub
Escape:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Continue
End Sub