Yes/No boxes in VBA - excel

Question

I have an array of shapes created in a for loop and want to assign simple code to each of them as "yes/no" buttons.
The code that creates the array of buttons is as follows:
Dim i As Integer
Dim j As Integer
Dim k As Integer
For i = 1 To 3
For j = 2 To 17
ActiveSheet.Shapes.addshape(msoShapeRectangle, Cells(j, i).Left + 0, _
Cells(j, i).Top + 0, Cells(j, i).Width, Cells(j, i).Height).Select
Next j
Next i
I would like to be able to assign code to each of the shapes as they are created but do not know how. What I want the code to do for each shape looks like the below. I want the shapes to react when clicked and cycle through yes/no/blank text in each of the shapes. The general logic of the code is below
value = value +1
if value = 1, then "yes" and green
if value = 2, then "no" and red
if value = 3, then value = 0 and blank and grey
Thank you in advance for your help

Answer 1

You can do something like this:
Option Explicit
Sub Tester()
Dim i As Long, j As Long, k As Long
Dim addr As String, shp As Shape
For i = 1 To 3
For j = 2 To 17
With ActiveSheet.Cells(j, i)
Set shp = .Parent.Shapes.AddShape(msoShapeRectangle, .Left + 0, _
.Top + 0, .Width, .Height)
With shp.TextFrame2
.VerticalAnchor = msoAnchorMiddle
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
End With
shp.Name = "Button_" & .Address(False, False)
End With
shp.Fill.ForeColor.RGB = RGB(200, 200, 200)
shp.OnAction = "ButtonClick"
Next j
Next i
End Sub
'called from a click on a shape
Sub ButtonClick()
Dim shp As Shape, capt As String, tr As TextRange2
'get a reference to the clicked-on shape
Set shp = ActiveSheet.Shapes(Application.Caller)
Set tr = shp.TextFrame2.TextRange
Select Case tr.Text 'decide based on current button text
Case "Yes"
tr.Text = ""
shp.Fill.ForeColor.RGB = RGB(200, 200, 200)
Case "No"
tr.Text = "Yes"
shp.Fill.ForeColor.RGB = vbGreen
Case ""
tr.Text = "No"
shp.Fill.ForeColor.RGB = vbRed
End Select
End Sub

Answer 2

Just to visualize my idea regarding using the selection change event instead of buttons:
The area that should be the clickable range is named clickArea - in this case B2:D17.
Then you put this code in the according sheet module
Option explicit
Private Const nameClickArea As String = "clickArea"
Private Enum bgValueColor
neutral = 15921906 'gray
yes = 11854022 'green
no = 11389944 'red
End Enum
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'whenever user clicks in the "clickArea" the changeValueAndColor macro is triggered
If Not Intersect(Target.Cells(1, 1), Application.Range(nameClickArea)) Is Nothing Then
changeValueAndColor Target.Cells(1, 1)
End If
End Sub
Private Sub changeValueAndColor(c As Range)
'this is to deselect the current cell so that user can select it again
Application.EnableEvents = False: Application.ScreenUpdating = False
With Application.Range(nameClickArea).Offset(50).Resize(1, 1)
.Select
End With
'this part changes the value and color according to the current value
With c
Select Case .Value
Case vbNullString
.Value = "yes"
.Interior.Color = yes
Case "yes"
.Value = "no"
.Interior.Color = no
Case "no"
.Value = vbNullString
.Interior.Color = neutral
End Select
End With
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub
And this is how it works - with each click on one of the cells value and background color are changed. You have to click on the image to start anmimation.
To reset everything I added a hyperlink that calls the reset action (and refers to itself)
Add this code to the sheets module
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
clearAll
End Sub
Private Sub clearAll()
With Application.Range(nameClickArea)
.ClearContents
.Interior.Color = neutral
End With
End Sub