Custom Option Buttons VBA

[jiri89]

Hi all

I am new here. Hopefully, it wont so challenging and someone can share idea on my issue.
I am creating a feedback survey with 10 questions which is based on option buttons.
But I’m not in love with standard excel option buttons because I can’t really do a whole lot of formatting on them; can’t change their size/colour and basically they just look old and ugly.

I decided to use my own shapes instead. In the following image, I’ve replaced the option buttons with shapes and have assigned a macro to each of them.
buttons.jpg

I have the following issue:
1) I don't know how to execute this macro multiple times for several questions on one sheet, i.e. have 10 questions where the user could select option 1-5 for each question.


2) Once the above is working, is there a neat way to calculate average score for the 10 questions?

I have attached the excel with code.
I would appreciate any input!!
Kind Regards,
Jiri

[Paul_Hossler]

I think you're make a LOT of work using individual event handlers for 10 x 5 = 50 Ovals

By positioning the Ovals in a cell it's much easier

'FormatSheet' adjusts row heights and column widths, and gives each of the 50 ovals a name that corresponds to the row/col of the .TopRightCell, and makes each .OnAction = 'Clicked'

'Clicked' uses .Caller to see which was clicked, and makes appropriate color changes for ovals in that row

'AverageButtons' count the green scores (1-5) and divides by 10

Option Explicit

Const LIGHT_GREY = 15921906 ' The result of RGB(242, 242, 242)
Const LIME = 52377 'The result of RGB(146, 212, 0)

Sub FormatSheet()
    Dim i As Long
    
    With ActiveSheet
        
        'rows
        For i = 2 To 10
            .Rows(10 + i).RowHeight = .Rows(11).RowHeight
        Next I
        
        'cols
        For i = 2 To 4
            .Columns(5 + i).ColumnWidth = .Columns(6).ColumnWidth
        Next i
        
        For i = 1 To .Shapes.Count
            With .Shapes(i)
                If .Type = msoAutoShape Then
                    If .AutoShapeType = msoShapeOval Then
                        .Select
                        Selection.OnAction = "Clicked"
                        .Fill.ForeColor.RGB = LIGHT_GREY
                        .Name = "OVAL-" & .TopLeftCell.Row & "-" & .TopLeftCell.Column
                    End If
                End If
            End With
            
        Next I
    
    End With
    
End Sub


Sub Clicked()
    Dim vCaller As Variant, vShape As Variant
    Dim i As Long, j As Long
    
    '(1) = caller row, (2) = caller col
    vCaller = Split(Application.Caller, "-")
    
    With ActiveSheet
        For i = 1 To .Shapes.Count
            With .Shapes(i)
                If .Type = msoAutoShape Then
                    If .AutoShapeType = msoShapeOval Then
                        vShape = Split(.Name, "-")
                        If vCaller(1) = vShape(1) Then      '   in same row
                            If vCaller(2) = vShape(2) Then      '   in same col
                                .Fill.ForeColor.RGB = LIME
                            Else
                                .Fill.ForeColor.RGB = LIGHT_GREY
                            End If
                        End If
                    End If
                End If
            End With
        Next i
    End With
End Sub

Sub AverageButtons()
    Dim i As Long, n As Long
    Dim vShape As Variant
    
    With ActiveSheet
        For i = 1 To .Shapes.Count
            With .Shapes(i)
                If .Type = msoAutoShape Then
                    If .AutoShapeType = msoShapeOval Then
                        If .Fill.ForeColor.RGB = LIME Then
                            vShape = Split(.Name, "-")
                            n = n + (vShape(2) - 5)
                        End If
                    End If
                End If
            End With
        Next i
    End With

    MsgBox "Average = " & Format(n / 10, "0.00")

End Sub

[SamT]

I definitely would use Paul's FormatSheet and Clicked Subs.

I think his scoring logic won't work since he is using the Ovals position to assign a score, and I think you want to mix up the relative score vs position.

I would modify the Oval Naming code to name them like: Q1A1, Q1A2...; Q2A1, Q2A2...etc thereby referencing both the Question number and the answer number. (Question #n Answer #n)

Then, either with 2 arrays in a module, or,my preference, two tables in a Very Hidden Sheet...
One to hold the Q score and one to hold the answer score values

The Question Score table would be 1 dimensional, with the QScore cleared whenever one of that Q's A ovals was clicked. the Answer Scores table would have Number of Questions Rows and Number of Answers Columns. Then the Clicked Answer oval's Answer Score would looked up and placed in the corresponding slot in the Q table

Question Scores		Answer Scores
50		5	50	20	45	15
15		50	30	15	25
75		75	25

After you have named all the Ovals, you can rearrange them from time to time without breaking the system, you can also move Q&A's up and down the sheet. All Questions don't need the same number of answers.

Example Table reference codes:
To refer to the Tables via "vCaller" in Paul's Clicked sub

Range(QTable).Cells(Mid(vCaller, 2)) = Range(ATable(Cells(Mid(vCaller, 2), Mid(vCaller, 4)"

Or you could add self documenting lines

Rw = Mid(vCaller, 2)
Col = Mid(vCaller, 4)
'and use
With Range(QTable).Cells(Rw)
.Value = 0
.Value = Range(ATable).Cells(rw, col)
End with

AverageScore = WorksheetFunction.Average(QTable)

Paul enjoys coding solutions as much as I enjoy providing algorithms. I like to watch you experiment with the coe til you figger it out on yer own

[Paul_Hossler]

My thinking (?) was to use the .TopLeftCell as much as possible, hence use something like

.Name = "OVAL-" & .TopLeftCell.Row & "-" & .TopLeftCell.Column

I wasn't sure about scoring, but again I used .TopLeftCell and my ASSUMPTION from the OP's attachment to use a score of 1 through 5 based on the clicked Oval.

Obviously, if the questions are a 'Quiz' with correct answers mixed, that won't work

It sort of looked like an Opinion Poll, with 1 = Hates, 3 = Don't Care, 5 = Loves so that's what I went with

Capture.JPG

[jiri89]

Thank you both for your amazing solutions! I really appreciate it.
My idea was exactly how Paul has pointed out. The user clicks 10 parameters resulting in an average score.

I was just quickly looking at Paul's code, it's very neat. Not what I would think about with my little experience.

Just three followup questions:
1) Is there a way to unclick the selected button so that it displays default gray again?
2) Currently, the AverageButtons function calculates total average both selected and unselected buttons. Example: If user selects 5 on Q1, the total average is 0,1 (5/50). Is there a way to calculate average only from selected buttons?
3) I will be using the calculated average dynamically for other formulas. Do you know of a way to autoupdate the AverageButtons function every time a button is clicked?

Thank you once again both of you for great responses. I appreciate your time and help.
Regards,
Jiri

[SamT]

Since it's like an opinion poll, you don't need an Answer Table. In that Case I would use an Array to hold the Question Scores, and set them with something like

QScoreArray(Rw) =0 'Rw & Col From my last suggested code
QScoreArray(Rw) = Col 'From my last suggested code

Although I would change the variable names "Rw" and "Col" to better describe the actions. Perhaps "QIndex" and "ARank"

With all that depending solely on the Oval Names, again you can move the Question/Answers up and down the page.

You need to verify, but I believe that

Public Function AverageScore() As Double
Dim i as Long
Dim Total As Long
Dim Cnt As Long

For i = LBound(QScoreArray) to UBound(QScoreArray)
   If QScoreArray(i) > 0 Then
   Cnt = Cnt + 1
   Total =Total +QScoreArray(i)
   End If
Next

If Cnt = 0 Then 'avoid Div by zero
   AverageScore = 0
   Exit Function
End If

AverageScore = Total/Cnt
End Function

can provide instant and continuous access to the average for all the other subs

[Paul_Hossler]

Try the attachment

Option Explicit

Const LIGHT_GREY = 15921906 ' The result of RGB(242, 242, 242)
Const LIME = 52377 'The result of RGB(146, 212, 0)
Const addrAverage As String = "P1"

Sub FormatSheet()
    Dim i As Long
    
    With ActiveSheet
        
        'rows
        For i = 2 To 10
            .Rows(10 + i).RowHeight = .Rows(11).RowHeight
        Next i
        
        'cols
        For i = 2 To 4
            .Columns(5 + i).ColumnWidth = .Columns(6).ColumnWidth
        Next i
        
        For i = 1 To .Shapes.Count
            With .Shapes(i)
                If .Type = msoAutoShape Then
                    If .AutoShapeType = msoShapeOval Then
                        .Select
                        Selection.OnAction = "Clicked"
                        .Fill.ForeColor.RGB = LIGHT_GREY
                        .Name = "OVAL-" & .TopLeftCell.Row & "-" & .TopLeftCell.Column
                    End If
                End If
            End With
            
        Next i
    
    End With
    
End Sub

Sub Clicked()
    Dim vCaller As Variant, vShape As Variant
    Dim i As Long, j As Long
    
    '(1) = caller row, (2) = caller col
    vCaller = Split(Application.Caller, "-")
    
    With ActiveSheet
        For i = 1 To .Shapes.Count
            With .Shapes(i)
                If .Type = msoAutoShape Then
                    If .AutoShapeType = msoShapeOval Then
                        vShape = Split(.Name, "-")
                        If vCaller(1) = vShape(1) Then      '   in same row
                            If vCaller(2) = vShape(2) Then      '   in same col
                                If .Fill.ForeColor.RGB = LIME Then
                                    .Fill.ForeColor.RGB = LIGHT_GREY
                                Else
                                    .Fill.ForeColor.RGB = LIME
                                End If
                            Else
                                .Fill.ForeColor.RGB = LIGHT_GREY
                            End If
                        End If
                    End If
                End If
            End With
        Next I
    End With
    AverageButtons
End Sub

Sub AverageButtons()
    Dim i As Long, cntResponses As Long, r As Long, c As Long, totResponses As Long
    Dim vShape As Variant
    Dim aryGreen(11 To 20) As Long     '   match .TopLeftCell row values
    
    'zero out stat array with -1 for no response
    For r = LBound(aryGreen, 1) To UBound(aryGreen, 1)
        aryGreen(r) = -1
    Next r
    
    With ActiveSheet
        For i = 1 To .Shapes.Count
            With .Shapes(i)
                If .Type = msoAutoShape Then
                    If .AutoShapeType = msoShapeOval Then
                        If .Fill.ForeColor.RGB = LIME Then
                            vShape = Split(.Name, "-")
                            aryGreen(vShape(1)) = (vShape(2) - 5)
                        End If
                    End If
                End If
            End With
        Next i
    End With
    cntResponses = 0
    totResponses = 0
    For r = LBound(aryGreen, 1) To UBound(aryGreen, 1)
        If aryGreen(r) <> -1 Then
            cntResponses = cntResponses + 1
            totResponses = totResponses + aryGreen(r)
        End If
    Next r
    If cntResponses > 0 Then
        ActiveSheet.Range(addrAverage).Value = totResponses / cntResponses
    Else
        ActiveSheet.Range(addrAverage).Value = CVErr(xlErrNum)
    End If
End Sub

[jiri89]

Absolutely amazing! Apologies for late reply and thank you so much. :-)

[jiri89]

Hey again,

I have been using your solution and it works perfectly. Once again thank you, very appreciated.

I was just wondering about a minor upgrade, if you could please help. I would like to be able to easily modify the number of rows with options with +/- option. Now I have a fixed number of 10, but what if I would like to add question row 11 by clicking "+ add row". Similarly, on a click "- remove row", I would get 9 rows. If this is possible, it would also be nice for it to automatically recalculate the base for calculating average score depending on how many question rows are there.

Once again, thank you for considering to help.
Best Regards
Jiri

[Paul_Hossler]

NP

Did it a little differently

You can Copy Insert or Delete a row and when you run FormatSheet it will find the rows and columns to use in the calculations


Play with the attachment and let me know

Private Sub FindQuestionsAnswers()
    Dim oPent As Shape
    
    'init
    rowPentagonsStart = ActiveSheet.Rows.Count
    rowPentagonsEnd = 0
    colOvalsStart = ActiveSheet.Columns.Count
    colOvalsEnd = 0

    For Each oPent In ActiveSheet.Shapes
        If oPent.Type = msoAutoShape Then
            If oPent.AutoShapeType = msoShapePentagon Then
                rowPentagonsStart = Application.WorksheetFunction.Min(oPent.TopLeftCell.Row, rowPentagonsStart)
                rowPentagonsEnd = Application.WorksheetFunction.Max(oPent.TopLeftCell.Row, rowPentagonsEnd)
            ElseIf oPent.AutoShapeType = msoShapeOval Then
                colOvalsStart = Application.WorksheetFunction.Min(oPent.TopLeftCell.Column, colOvalsStart)
                colOvalsEnd = Application.WorksheetFunction.Max(oPent.TopLeftCell.Column, colOvalsEnd)
            End If
        End If
    Next

End Sub