VBA how to Create Multi Select ListBoxes in qualifying cells - excel

Question

I am trying to achieve code where multi-select ListBoxes are added if Column 4 or 5 are selected and Column 2 in the same row has the string "has options".
The Listboxes contain values from named ranges called "option1" and "option2". Current Selections are output to the respective cell in Column 4 or 5 separated by commas.
This is the code I have in "This Workbook" object. It needs to work on all sheets.
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = 4 And Target.OFFSET(0, -1).Value = "has options" Then
CreateOpt1PopUp Target
End If
If Target.Column = 5 And Target.OFFSET(0, -2).Value = "has options" Then
CreateOpt2PopUp Target
End If
Else
DeleteAllOpt1PopUps Target
DeleteAllOpt2PopUps Target
End If
End If
End Sub
This is the code I have in a Module. The criteria has evolved and therefore I have amended the code multiple times to the point where it no longer works.
Private opt1SelectCell As Range
Public Function Opt1Area(ByRef ws As Worksheet) As Range
Const OPT1_COL As Long = 4
Dim lastOpt1Row As Long
With ws
lastOpt1Row = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
If lastOpt1Row = 0 Then
Set Opt1Area = Nothing
Else
Set Opt1Area = .Cells(2, OPT1_COL).Resize(lastOpt1Row, 1)
End If
End With
End Function
Public Sub Opt1BoxClick()
Dim opt1BoxName As String
opt1BoxName = Application.Caller
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes(opt1BoxName)
Dim opt1List As String
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.Selected(i) Then
opt1List = opt1List & opt1Box.List(i) & ","
End If
Next i
If Len(opt1List) > 0 Then
opt1List = Left$(opt1List, Len(opt1List) - 1)
End If
opt1SelectCell.Value = opt1List
End Sub
Public Function Opt1ListArea() As Range
Set Opt1ListArea = ActiveSheet.Range("option1")
End Function
Public Sub DeleteAllOpt1PopUps(ByRef selectedCell As Range)
Dim opt1Box As ListBox
For Each opt1Box In selectedCell.Parent.ListBoxes
opt1Box.Delete
Next opt1Box
End Sub
Public Sub CreateOpt1PopUp(ByRef selectedCell As Range)
Set opt1SelectCell = selectedCell
Dim Opt1PopUpCell As Range
Set Opt1PopUpCell = opt1SelectCell.OFFSET(1, 0)
DeleteAllOpt1PopUps selectedCell
'--- now create listbox
Const OPT1_POPUP_WIDTH As Double = 75
Const OPT1_POPUP_HEIGHT As Double = 110
Const OPT1_OFFSET As Double = 5#
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes.Add(Opt1PopUpCell.Left + OPT1_OFFSET, _
Opt1PopUpCell.Top + OPT1_OFFSET, _
OPT1_POPUP_WIDTH, _
OPT1_POPUP_HEIGHT)
With opt1Box
.ListFillRange = Opt1ListArea().Address(external:=True)
.LinkedCell = ""
.MultiSelect = xlSimple
.Display3DShading = True
.OnAction = "Module1.Opt1BoxClick"
End With
'--- is there an existing list of options selected?
Dim selectedOptions1() As String
selectedOptions1 = Split(opt1SelectCell.Value, ",")
Dim opt1 As Variant
For Each opt1 In selectedOptions1
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.List(i) = opt1 Then
opt1Box.Selected(i) = True
Exit For
End If
Next i
Next opt1
End Sub
This is an example of the excel data.
How can I make this work and even improve it?