Creating a Multi Selection Checkbox List in Side-by-Side Cell Across Row in Excel - excel

Question

I'm using VB code created by L42 on 4/27/14 that creates a checkbox list in a single cell.
Option Explicit
Dim fillRng As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBobj As OLEObject
Dim i As Long
Set LBobj=Me.OLEObjects("LB_Colors")
Set LBColors = Target
If Not Intersect(Target, [B2]) Is Nothing Then
Set fillRng = Target
With LBobj
.Left = fillRng.Left
.Top = fillRng.Top
.Width = fillRng.Width
.Visible = True
End With
Else
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount -1
If fillRng.Value = Then
If .Selected(i) Then fillRng.Value = .List(i)
Else
If .Selected(i) Then fillRng.Value = _
fillRng.Value & "," & .List(i)
End If
Next
End With
Set fillRng = Nothing
End If
End If
End Sub
The code works perfectly and I was able to extend the checkbox list to the cells in complete column by changing the (Target, [B1:B40]). Following this logic, I thought that I could extend checkboxes C and D columns by (Target, [B1:D40]. However, after selecting desired items in B column and clicking or tabing over to C column, the entire checkbox moves with selected items without writing in the previous cell. I would like to be able to tab over or click to the next cell in the row and have same checkbox items that populates that cell with item selected, independent of the previous cell. Then tab or click to succeeding cells and do the same and have cells retain and display selected the items. Can this code be modified to do that?
Thank you.

Answer 1

to always put the values in the cell, just change your code to something like this:
Option Explicit
Dim fillRng As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBobj As OLEObject
Dim i As Long
Set LBobj = Me.OLEObjects("LB_Colors")
Set LBColors = Target
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If .Selected(i) Then
If fillRng.Value = "" Then
fillRng.Value = .List(i)
Else
fillRng.Value = fillRng.Value & "," & .List(i)
End If
End If
Next
End If
End With
Set fillRng = Nothing
End If
If Not Intersect(Target, [B1:D40]) Is Nothing Then
Set fillRng = Target
With LBobj
.Left = fillRng.Left
.Top = fillRng.Top
.Width = fillRng.Width
.Visible = True
End With
End If
End Sub