How to ID cell location of object when clicked on?

[LvBombero]

I am creating an Excel form with multiple questions that typically have a Yes or No box (cell next to Yes and No). The box cells have an invisible object over them. The object has an assigned macro that places an "X" in the cell under the object and removes the "X" from the other cell (either Yes or No box).

I would like to create VB code that I don't have to adjust every time I move the question to a different row or column. If I knew the VB code that would identify the cell the object was clicked on, I could then use that info to fill the cell below.

Any help would be greatly appreciated.

Thank you

 

[HalfAce]

For what it's worth, the cell selection thing would work just fine (as long as the columns of interest remain the same) but I have to admit, I would likely go with framed option buttons like Gary suggests.

 

[Gary McMaster]

Here's a crude sample (of what I think you're attempting) using option buttons.

To try it paste all the code in a standard module in a brand new workbook.

Run the "Setup" procedure first. That will create some randomly placed "Questions" in column A.

Click the "yes/no option" buttons then run "Show_Answers" procedure.

Add, remove or move some of the questions in column A then run "Buttons_Delete" and then "Buttons_Add" in that order. This will delete all of the existing buttons and recreate new ones that align with the new arrangement of questions in column A.

You can use the "Clear_Answers" procedure to un-set all of the option buttons.

Hope it's somewhere close to what you're trying to do. I believe the option buttons will get rid of a lot of overhead in making sure both are not selected (unless both = maybe), clearing one when the other is selected etc.

Gary

Option Explicit


Public Sub Buttons_Add()

Dim oSheet As Worksheet
Dim lLastRow As Long
Dim lColOffset As Long

Dim oCell As Range
Dim oQRange As Range
Dim oAnswerBox As Range
Dim siGroupWidth As Single
Dim siGroupHeight As Single

Dim oFrame As GroupBox
Dim oOption As OptionButton

Set oSheet = ActiveSheet

lLastRow = oSheet.Range("A" & Rows.Count).End(xlUp).Row 'Change "A" to column containing questions

'Question range = A1 to last used cell in col A
Set oQRange = oSheet.Range("A1:A" & lLastRow) 'Adjust range containing question to suit

lColOffset = 4 ' Number of columns to offset option buttons from "questions" column
siGroupWidth = 120 ' Width of frame (Note: option button must fit completely inside)
siGroupHeight = 40 ' Height of frame (Note: option button must fit completely inside)

For Each oCell In oQRange 'If there's a question add a frame and 2 option buttons (offset specified #cols)
    If oCell.Value <> "" Then
    
        'Append question cell address to control names for later query if needed
        Set oAnswerBox = oCell.Offset(-1, lColOffset)
        Set oFrame = oSheet.GroupBoxes.Add(oAnswerBox.Left, oAnswerBox.Top, siGroupWidth, siGroupHeight)
        oFrame.Visible = False ' Hide the frame
        oFrame.Name = "Frame" & oCell.Address 'Name = "Frame" w/appended cell address of question for later ID

        'Insure option button fits inside above frame to insure mutually exclusive toggle
        Set oOption = oSheet.OptionButtons.Add(oAnswerBox.Left + 10, oAnswerBox.Top + 10, siGroupWidth / 2, siGroupHeight / 2)
        oOption.Name = "Option" & oCell.Address & "Yes" 'Name = "Option" w/appended cell address of question + "Yes" for later ID
        oOption.Caption = "Yes"
        
        'Insure option button fits inside above frame to insure mutually exclusive toggle
        Set oOption = oSheet.OptionButtons.Add(oAnswerBox.Left + 40, oAnswerBox.Top + 10, siGroupWidth / 2, siGroupHeight / 2)
        oOption.Name = "Option" & oCell.Address & "No" 'Name = "Option" w/appended cell address of question + "No" for later ID
        oOption.Caption = "No"

   End If
Next oCell

End Sub



Public Sub Buttons_Delete()

Dim oShape As Shape

'Delete all shapes having names starting with "Fra" or "Opt"
For Each oShape In ActiveSheet.Shapes
    If Left(oShape.Name, 3) = "Fra" Or Left(oShape.Name, 3) = "Opt" Then
        oShape.Delete
    End If
Next oShape

End Sub

Public Sub Setup()

Buttons_Delete

ActiveSheet.Range("A5").Value = "Question 1?"

ActiveSheet.Range("A9").Value = "Question 2?"

ActiveSheet.Range("A16").Value = "Question 3?"

ActiveSheet.Range("A27").Value = "Question 4?"

ActiveSheet.Range("A33").Value = "Question 5?"

ActiveSheet.Range("A35").Value = "Question 6?"

ActiveSheet.Range("A36").Value = "Question 7?"

ActiveSheet.Range("A38").Value = "Question 8?"

Buttons_Add

'Manually change position of questions then run "Buttons_Delete" & "Buttons_Add" in that order

End Sub

Public Sub Show_Answers()

Dim oSheet As Worksheet
Dim lLastRow As Long
Dim sAnswers As String
Dim oOptYes As Shape
Dim oOptNo As Shape
Dim iQCount As Integer
Dim oCell As Range
Dim oQRange As Range

Set oSheet = ActiveSheet

lLastRow = oSheet.Range("A" & Rows.Count).End(xlUp).Row

Set oQRange = oSheet.Range("A1:A" & lLastRow)

sAnswers = ""
iQCount = 1
For Each oCell In oQRange
    If oCell.Value <> "" Then
    
        'Address option buttons by unique name assigned in "Buttons_Add"
        Set oOptYes = oSheet.Shapes("Option" & oCell.Address & "Yes")
        Set oOptNo = oSheet.Shapes("Option" & oCell.Address & "No")
        
        Select Case oOptYes.ControlFormat.Value & oOptNo.ControlFormat.Value
        
            Case "1-4146"
                sAnswers = sAnswers & "Question " & iQCount & vbTab & "Yes" & vbCrLf
            Case "-41461"
                sAnswers = sAnswers & "Question " & iQCount & vbTab & "No" & vbCrLf
            Case Else
                MsgBox "You didn't answer all the questions. Please try again!"
                Exit Sub
        End Select
        
        iQCount = iQCount + 1
        
    End If
Next oCell

MsgBox sAnswers

End Sub

Public Sub Clear_Answers()

Dim oShape As Shape

For Each oShape In ActiveSheet.Shapes
    If Left(oShape.Name, 3) = "Opt" Then
        oShape.ControlFormat.Value = False
    End If
Next oShape

End Sub

 

[LvBombero]

HalfAce, that is pretty slick. I definitely learned something. Greg you make a great point. After thinking about it, in order to have code that won't have to be changed every time I move a question, I have to go back to my original idea (ID cell location of object when clicked on).

Maybe if I put the parts that are missing in {}, it might be easier to figure out. Here goes:

Sub Q1_Yes()
'
' Q1 Yes box Macro
'
' Determine cell location by mouse click
Let R = {code to get row location}
Let C = {code to get column location}
Let Q1YesCell = """ & R & C & """
Let C = {code to add 4 columns to the right of C}
Let Q1NoCell = """ & R & C & """
'
Range(Q1YesCell).Select
If Range(Q1YesCell).Value = "X" Then
Range(Q1YesCell).Value = ""
Exit Sub
End If
Range(Q1NoCell).Value = ""
Range(Q1YesCell).Value = "X"
End Sub


Hopefully you guys can fill in the blanks. I will probably breakout the row & column identifier into it's own sub to minimize code. This should help in simplifying my form development.

Your point (Greg) on tracking answers will be done by dumping all the answers in a hidden column to be uploaded to a database after all the questions have been answered.

Thanks again.

 

[LvBombero]

Wow, that is awesome. I can not thank you guys for all the great help. I have learned a lot on just trying to figure out how the code works. I am very impressed with all of your suggestions and expertise. I think I got it now.

Thank you very much!

LV Bombero