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

CodePudding user response：

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

CodePudding user response：

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