Check box - multiple cells

[wgibcus]

I have hacked together the following code from various forum posts that does sort of what I want. In a nutshell, I would like code for multiple check boxes in a spreadsheet that may or may not be adjacent to each other. The checkbox must display a check mark (tick) from Wingdings (must be from Wingdings). This is because the data will ultimately be mail merged into a Word document with very specific formatting. The current code displays a dot (which is not ideal) and off-sets the cell selection by two. This is the only way I could get the check box to be able to be checked and unchecked by a single click without having to select another cell first (this is critical). This is kludgy and I need more elegant code If necessary single-click to check, double-click to uncheck would be a good compromise.

Any help is greatly appreciated.

Wayne

For context, the spreadsheet in question can be found at http://wa.yne.cc/template.xls

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const WS_RANGE As String = "B3:B28:F3:F28,H3:H28:L3:L28,N3:N28:R3:R28,T3:T28:X3:X28,Z3:Z28:AD3:AD28,AF3:AF28:AJ3:AJ28,AL3:AL28:AP3:AP28,AR3:AR28:AV3:AV28,AX3:AX28:BB3:BB28,BD3:BD28:BH3:BH28,BJ3:BJ28:BN3:BN28,BP3:BP28:BT3:BT28" '<=== change to suit

On Error GoTo err_handler
Application.EnableEvents = False
If Not Application.Intersect(Target, Range(WS_RANGE)) Is Nothing Then
With Target
.Font.Name = "WingDings"
Select Case .Value
Case "l": .Value = ""
Case Else: .Value = "l"
End Select
.Offset(2, 0).Select
End With
End If
err_handler:
Application.EnableEvents = True
End Sub

 

[Gary McMaster]

Hi Wayne,

Here's a sample that uses cells hyperlinked to themselves. It allows manipulating a cell via the "Worksheet_FollowHyperlink" event. It will at least handle the "single click" part of your description.

Not sure if it's what you want but I hope it helps.

Gary

In a standard module:

Public Sub CreateLinks()
 
Dim oLink As Hyperlink
Dim oCell As Range
Dim oRange As Range
 
'Delete all existing hyperlinks
For Each oLink In ActiveSheet.Hyperlinks
    Set oCell = Range(oLink.SubAddress)
    oLink.Delete
Next
 
Set oRange = ActiveSheet.Range("A1:A10")
 
For Each oCell In oRange
    ActiveSheet.Hyperlinks.Add Anchor:=oCell, Address:="", SubAddress:=oCell.Address, _
    TextToDisplay:=Chr(168), ScreenTip:="Click to Check / Un-check"
Next
 
oRange.Font.Name = "Wingdings"
oRange.Font.Underline = False
oRange.Font.ColorIndex = xlAutomatic
 
End Sub

In the "Worksheet_FollowHyperlink" event:

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
 
If Range(Target.SubAddress).Value = Chr(168) Then
    Range(Target.SubAddress).Value = Chr(254)
Else
    Range(Target.SubAddress).Value = Chr(168)
End If
 
End Sub

 

[wgibcus]

Gary,

Thanks for the quick response. The code is awesome and I will save this for another project I'm working on but unfortunately this is not what I need now. I should've been clearer in the language I used. I need a check mark (tick) in a cell, not a checkbox that can be checked The code you provided won't work because I can't mail merge it into Word. If you look at the example spreadsheet I provided, you'll see what I mean. I need to turn the dot into a tick and get rid of the offsetting so that you can check and uncheck the cell with a single click.

Wayne

 

[Gary McMaster]

A wingdings check mark is Chr(252)(according to "Character Map"). You could use that (or anything else you want) in your code instead of the checkboxes I used.

Your code modified:

If Not Application.Intersect(Target, Range(WS_RANGE)) Is Nothing Then
    With Target
        .Font.Name = "WingDings"
        Select Case .Value
            Case Chr(252):    .Value = ""
            Case Else:   .Value = Chr(252)
        End Select
        .Offset(2, 0).Select
    End With
End If

I looked at your sheet. It appears that you could make the hyperlink technique work if all you are looking for is to toggle a cell from one character to another. Of course you would have to create the links for every cell involved not just A1-A10 like I did in the sample. I guess I'm not following you on the mail merge part of the deal.

Gary

 

[wgibcus]

Thanks. That indeed does change the dot to a tick - fantastic. I found the following code which again, sort of does what I need (from http://www.mrexcel.com/forum/showthread.php?t=25137). It will put a tick in a cell when you double-click it. The problem is, I can't figure out how to change the code so that I can put the tick into multiple selected columns.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Count > 1 Then Exit Sub
    If Target.Column <> 1 Then Exit Sub
    If Target.Row > Range("B65536").End(xlUp).Row Then Exit Sub
    If IsEmpty(Target) Then
        Target.Formula = "=CHAR(252)"
        Target.Value = Target.Value
        With Target.Font
            .Name = "Wingdings"
            .FontStyle = "Bold"
            .Size = 8
        End With
        Target.Borders.LineStyle = xlContinuous
    Else
        Target.ClearContents
    End If
    Cancel = True
End Sub