PDA

View Full Version : Custom Option Buttons VBA



jiri89
07-27-2017, 06:45 AM
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.
19898

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
07-27-2017, 08:09 AM
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
07-27-2017, 09:15 AM
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
07-27-2017, 10:48 AM
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

19903

jiri89
07-27-2017, 11:20 AM
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
07-27-2017, 11:52 AM
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
07-27-2017, 12:16 PM
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
08-02-2017, 08:20 AM
Absolutely amazing! Apologies for late reply and thank you so much. :-)

jiri89
08-17-2017, 11:54 AM
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
08-17-2017, 02:11 PM
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