Managing the intersect VBA function - excel

Question

I'm currently implementing some VBA code that allows a listbox to trigger on certain columns and then once filled in the cell gets filled with the selection. The initial solution has been adapted from Checkboxes for multiple values in a single cell in Excel except instead of triggering on a specific cell I want it triggered for specific cells within an entire column. I've managed to adapt this code just fine and the boxes fill in, but they only update if the next selected cell is outside that entire column (as they still fall within the intersect otherwise). Is there a way to allow intersect to account for any cell selection change? I just want the content to fill in regardless of whether I select a cell on a different column (which works) or a different row (which doesn't). I've put the code in here but it's a broad copy of the linked code above.
Thanks in advance!
Option Explicit
Dim fillRng As Range
Dim fillRngp As Range
Dim fillRngr As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBPers As MSForms.ListBox
Dim LBRec As MSForms.ListBox
Dim LBobj As OLEObject
Dim LBoba As OLEObject
Dim LBObr As OLEObject
Dim i As Long
Set LBobj = Me.OLEObjects("LB_Process")
Set LBColors = LBobj.Object
Set LBoba = Me.OLEObjects("LB_Personal")
Set LBPers = LBoba.Object
Set LBObr = Me.OLEObjects("LB_Record")
Set LBRec = LBObr.Object
If Selection.Count > 1 Then
Else
If Not Intersect(Target, Range("G5:G10000")) Is Nothing Then
Set fillRng = Target
With LBColors
.Left = fillRng.Offset(0, 1).Left
.Top = fillRng.Offset(0, 1).Top
.Width = fillRng.Offset(0, 1).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 If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRng = Nothing
Set fillRngp = Nothing
Set fillRngr = Nothing
End If
End If
If Not Intersect(Target, Range("M5:M10000")) Is Nothing Then
Set fillRngp = Target
With LBPers
.Left = fillRngp.Offset(0, 1).Left
.Top = fillRngp.Offset(0, 1).Top
.Width = fillRngp.Offset(0, 1).Width
.Visible = True
End With
Else
LBoba.Visible = False
If Not fillRngp Is Nothing Then
fillRngp.ClearContents
With LBPers
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRngp.Value = "" Then
If .Selected(i) Then fillRngp.Value = .List(i)
Else
If .Selected(i) Then fillRngp.Value = _
fillRngp.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRngp = Nothing
Set fillRng = Nothing
Set fillRngr = Nothing
End If
End If
If Not Intersect(Target, Range("O5:O10000")) Is Nothing Then
Set fillRngr = Target
With LBRec
.Left = fillRngr.Offset(0, 1).Left
.Top = fillRngr.Offset(0, 1).Top
.Width = fillRngr.Offset(0, 1).Width
.Visible = True
End With
Else
LBRec.Visible = False
If Not fillRngr Is Nothing Then
fillRngr.ClearContents
With LBRec
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRngr.Value = "" Then
If .Selected(i) Then fillRngr.Value = .List(i)
Else
If .Selected(i) Then fillRngr.Value = _
fillRngr.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRng = Nothing
Set fillRngp = Nothing
Set fillRngr = Nothing
End If
End If
End If
End Sub

Answer 1

Try this - there's a lot of repetition in your posted version which can be factored away since all three listboxes get used the same way.
I also added in a method to synchronize the listbox with any existing data already in the cell.
Option Explicit
Dim fillRng As Range 'any previously-selected cell
Dim theOLE As OLEObject 'any visible listbox container
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim theLB As MSForms.ListBox
'any list visible ?
If Not theOLE Is Nothing Then
'clean up after previous list editing
Set theLB = theOLE.Object 'from the global
fillRng.Value = LBSelectedItems(theLB) 'comma-separated list of selections
theOLE.Visible = False
Set theOLE = Nothing 'clear globals
Set fillRng = Nothing
End If
'need to exit now?
If Target.Count <> 1 Then Exit Sub
If Target.Row < 5 Or Target.Row > 10000 Then Exit Sub
'which column are we dealing with
Select Case Target.Column
Case 7: Set theOLE = Me.OLEObjects("LB_Process")
Case 13: Set theOLE = Me.OLEObjects("LB_Personal")
Case 15: Set theOLE = Me.OLEObjects("LB_Record")
Case Else: Exit Sub '<< nothing else to do here
End Select
Set fillRng = Target ' populate globals
Set theLB = theOLE.Object
SetList fillRng, theLB ' any cell value to sync with the list?
With theLB
.Left = fillRng.Offset(0, 1).Left
.Top = fillRng.Offset(0, 1).Top
.Width = fillRng.Offset(0, 1).Width
.Visible = True
End With
End Sub
'select list items, based on any existing value in the cell
Sub SetList(rng As Range, LB As MSForms.ListBox)
Dim arr, i As Long
If Len(rng.Value) = 0 Then Exit Sub 'nothing to do...
arr = Split(rng.Value, ",") 'existing choices are comma-delimited
For i = 0 To LB.ListCount - 1
'?list item matches value from cell?
If Not IsError(Application.Match(LB.List(i), arr, 0)) Then
LB.Selected(i) = True
End If
Next i
End Sub
'return a comma-delimted list of selected items from a listbox
Function LBSelectedItems(LB As MSForms.ListBox)
Dim i As Long, lst, sep
For i = 0 To LB.ListCount - 1
If LB.Selected(i) Then
lst = lst & sep & LB.List(i)
sep = "," 'at least one selection, so need a separator
LB.Selected(i) = False 'deselect after checking
End If
Next i
LBSelectedItems = lst
End Function