Gary,
If you have a lot of parts to select from and/or you will be adding and
deleting parts from the lists then using check boxes will be problematic
because of the need to add/delete the controls etc. Also, ActiveX controls
are notorious for causing problems if you have too many. Check boxes from the
Forms toolbar have a minimum size which may not be small enough and may also
lead to problems if you have too many (assumption on my part).
I think I would forget using controls and use the WorksheetSelection_Change
event to toggle the text of the cells in the columns adjacent each parts
list. If the font style for these cells is set to Marlett, then toggling
between "a" and "" will achieve the desired affect. Note that an "a" in
Marlett font is a check mark.
The advantage of this approach is that you can use Dynamic Named ranges to
reference the cells of each list which will automatically adjust to changes
in the size of the lists. This can hold also for the cells in the adjacent
columns that exhibit the above behaviour - i.e. no maintenance required.
Under the assumption that you are not very familiar with code and Dynamic
Named ranges, I wrote the below elaborate code which you can use to set all
this up. The larger macro is intended to only be used once ON A NEW WORKBOOK
to set it all up including required code. The smaller macro is intended to be
used to update the selected parts list. Note that this code was written just
now with minimal testing and is risky. It is intended as an example only.
Regards,
Greg
Sub SetUp()
'Only run this once in new workbook
Dim ws As Worksheet
Dim c As Range
Dim Code As String
Dim txt1 As String, txt2 As String
Dim Nm As Name
Dim FoundNm1 As Boolean, FoundNm2 As Boolean
Dim checkline As String
Dim i As Integer, ii As Integer
Dim x As Integer, Ln As Long
i = 0: x = 0
FoundNm1 = False: FoundNm2 = False
checkline = "Worksheet_SelectionChange"
Sheets(1).Name = "Selected Parts"
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Selected Parts" Then
i = i + 1
ws.Name = "List " & i
ws.Cells.RowHeight = 12.75
ws.Columns(1).Locked = False
With ws.Columns(2)
..Locked = True
..ColumnWidth = 2.25
..Font.Name = "Marlett"
..Font.Bold = False
..HorizontalAlignment = xlCenter
..VerticalAlignment = xlCenter
End With
For ii = 1 To 25
x = x + 1
ws.Cells(ii, 1) = "Part " & x
Next
txt1 = "=Offset('" & ws.Name & "'!$A$1, 0, 0, " & _
"CountA('" & ws.Name & "'!$A:$A), 1)"
txt2 = "=Offset(PartsList" & i & ", 0, 1)"
For Each Nm In ThisWorkbook.Names
If Nm.Name = "PartsList" & i Then FoundNm1 = True
If Nm.Name = "CheckList" & i Then FoundNm2 = True
Next
With ThisWorkbook
If Not FoundNm1 Then .Names.Add "PartsList" & i, txt1 _
Else .Names("PartsList" & i).RefersTo = txt1
If Not FoundNm2 Then .Names.Add "CheckList" & i, txt2 _
Else .Names("CheckList" & i).RefersTo = txt2
End With
FoundNm1 = False: FoundNm2 = False
Code = "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" & _
vbCr & "If Target.Count > 1 Then Exit Sub" & _
vbCr & "If Not Intersect(Target, Range(""CheckList" & i & """)) Is Nothing
Then" & _
vbCr & "If Target = """" Then" & _
vbCr & "Target = ""a""" & _
vbCr & " Else" & _
vbCr & "Target = """"" & _
vbCr & "End If" & _
vbCr & "End If" & _
vbCr & "End Sub"
With ThisWorkbook.VBProject.VBComponents(ws.CodeName).CodeModule
Ln = .CountOfLines
If Not .Find(checkline, 1, 1, Ln, 1) Then .InsertLines Ln + 1, Code
End With
'ws.Protect UserInterfaceOnly:=True
End If
Next
End Sub
Sub UpdateSelectedParts()
'Use this macro to update selected parts
Dim ws As Worksheet
Dim Nm As Name
Dim rng As Range, c As Range, cc As Range
Dim rw As Long
Dim i As Integer
Set ws = Sheets("Selected Parts")
ws.Columns(1).ClearContents
ws.Range("A1") = "Selected Parts"
Set c = Range("A2")
i = 1
For Each Nm In ThisWorkbook.Names
If Left(Nm.Name, 9) = "PartsList" Then
For Each cc In Range(Nm.Name)
If cc(1, 2) = "a" Then
c(i) = cc
i = i + 1
End If
Next
End If
Next
End Sub
