Enter check mark with one cell click, and ability to change selection in a range

[HughT]

I am creating a form where the user is to select one option only from a range of five cells in a row.

I want the user to be able to select a cell within a range and insert a check mark with one click, and delete any previous check marks within the range. The user must also be able to delete all check marks (eg by use of Delete key)

So, range A1:E1

User clicks B1, check mark is inserted
User then clicks C1, check mark is deleted from B1, check mark is inserted in C1

Many thanks, VBA newbie, and as I want to use this function on different rows and columns, detailed instructions on how to change code would be appreciated!

HughT

 

[MickG]

Try this:-

Private [COLOR="Navy"]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]If[/COLOR] Not Intersect(Target, Range("A1:E1")) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
Range("A1:E1").ClearContents
[COLOR="Navy"]With[/COLOR] Target
    .Font.Name = "Wingdings"
    .Value = Chr(252)
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[HughT]

Mick

Thank you very much!

I want to be able to use this on multiple rows and columns, eg A1:E1 to A200:E200, and N1:S1 to N200:S200 etc.

Is there a way to do this without creating a separate piece of code for each range? Not a problem for all of A:E and N:S as that would only be two lots of code, but potentially 200 separate pieces of code for A1:E1 to A200:E200 would create difficulties.

Thank you

Hugh

 

[MickG]

Try this:-

Private [COLOR="Navy"]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
[COLOR="Navy"]If[/COLOR] Not Intersect(Target, Range("A1:E200")) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]With[/COLOR] Target
    Cells(.Row, .Column - (.Column - 1)).Resize(, 5).ClearContents
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Target
    .Font.Name = "Wingdings"
    .Value = Chr(252)
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]ElseIf[/COLOR] Not Intersect(Target, Range("N1:S200")) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]With[/COLOR] Target
    Cells(.Row, .Column - (.Column - 14)).Resize(, 5).ClearContents
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Target
    .Font.Name = "Wingdings"
    .Value = Chr(252)
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[HughT]

Mick

Thank you very much, that worked brilliantly, but...

I selected the columns to widen them, and every single cell populated with a checkmark, and any text changed to Wingdings!

It is lovely to have several thousand check marks telling me how much my spreadsheet appreciated your effort, but it sort of doesn't do the job!

Sorry to be a pain, any way round this?

As an alternative, I can get by without the automatic checkmark clicky function if it is too difficult and simply insert 'x' instead manually, but it would still be good to have the ability to only enter one 'x' in the range. Can this be achieved with a formula?

Many thanks for your help

Hugh

 

[MickG]

Sorry about that:
Amend the code where shown "<<<<"

Private [COLOR="Navy"]Sub[/COLOR] Worksheet_SelectionChange(ByVal Target [COLOR="Navy"]As[/COLOR] Range)
If Target.Count = 1 Then '[COLOR="Green"][B]<<<<<<<:- Add this line[/B][/COLOR]
[COLOR="Navy"]If[/COLOR] Not Intersect(Target, Range("A1:E200")) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]With[/COLOR] Target
    Cells(.Row, .Column - (.Column - 1)).Resize(, 5).ClearContents
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Target
    .Font.Name = "Wingdings"
    .Value = Chr(252)
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]ElseIf[/COLOR] Not Intersect(Target, Range("N1:S200")) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]With[/COLOR] Target
    Cells(.Row, .Column - (.Column - 14)).Resize(, 5).ClearContents
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Target
    .Font.Name = "Wingdings"
    .Value = Chr(252)
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] If
End If   '[COLOR="Green"][B]<<<<<<<:- Add this line[/B][/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[HughT]

Mick

Thank you very much, that worked perfectly!

This is a really brilliant tool as it makes the User Experience so much easier than inserting 'x's in boxes.

Hugh

 

[MickG]

You're welcome

 

[HughT]

Oops

Spoke to soon!

I amended the code because I had moved some columns around and added others, and it worked until I moved to another worksheet.

Code is as under:

With Target
Cells(.Row, .Column - (.Column - 9)).Resize(, 4).ClearContents
End With
With Target
.Font.Name = "Wingdings"
.Value = Chr(252)
End With
ElseIf Not Intersect(Target, Range("M8:T200")) Is Nothing Then
With Target
Cells(.Row, .Column - (.Column - 13)).Resize(, 8).ClearContents
End With
With Target
.Font.Name = "Wingdings"
.Value = Chr(252)
End With
ElseIf Not Intersect(Target, Range("w8:az200")) Is Nothing Then
With Target
Cells(.Row, .Column - (.Column - 23)).Resize(, 30).ClearContents
End With
With Target
.Font.Name = "Wingdings"
.Value = Chr(252)
End With
End If
End If
End Sub

I now get a Compile Error - Invalid Outside Procedure message.

What have I done wrong?

Hugh

 

[MickG]

The first few lines of your code seem to be missing!!!!
Something Like:-

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count = 1 Then 
If Not Intersect(Target, Range("A1:E200")) Is Nothing Then