Managing the intersect VBA function

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