How to code a multi Select Listbox in a Single Cell

Hi, I am new to VBA and I really need some help. I am basically trying to do the following steps:
I want to doubleclick on a cell which opens a Listbox. From this Listbox I can select multiple items (which I manage on another sheet) and add multiple items to my cell (which are seperated by commas)

This is my code so far but I don't really know how to tell my listbox to add items to the cell I am clicking on.

Option Explicit

Private Sub ListBox1_Click()

End Sub
Private Sub CommandButton1_Click()
Worksheets("Tabelle1").Activate

Dim i As Integer
With UserForm1.ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then
MsgBox .List(i) 'Gebe die ausgewählten Elemente aus
ActiveSheet.Cells=3 .Value = .List(i)
Else
'Nichts passiert
End If
Next i
End With

End Sub

Private Sub UserForm_Initialize()
Worksheets("Tätigkeiten").Activate
UserForm1.ListBox1.RowSource = "A1:A31"

ListBox1.ListStyle = fmListStyleOption
End Sub

Hi & welcome to the board.
place this in the sheet module

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   Cancel = True
   UserForm1.Tag = Target.Address
   UserForm1.Show
   
End Sub

Change the part in red to match the name of your userform.And for the button use

Private Sub CommandButton1_Click()
Worksheets("Tabelle1").Activate
Dim i As Integer
With UserForm1.ListBox1
   For i = 0 To .ListCount - 1
      If .Selected(i) Then
         MsgBox .List(i) 'Gebe die ausgewählten Elemente aus
         Range(Me.Tag).Value = Range(Me.Tag).Value & "," & .List(i)
      End If
   Next i
End With

End Sub

Also please amend your post to use code tags, the # icon in the reply/edit window

Dear Fluff13, thank you so much for your reply. I worked partly fine but there must be another mistake I am still missing to see. So I changed to code on the Basis a blogpost from microsoft

Unfortunately Excel VBA keeps telling me that the following Sub or function is not defined:

Sub ListBox1_Keypress(ByVal KeyAscii As MSForms.ReturnInteger)

If KeyAscii <> 13 Then
  ClearBoxSelections
  Exit Sub
End If

This is the entire Code I adjusted:

Private Sub ListBox1_Click()

End Sub

'Get active cell column; is cell address in correct column?
'If not correct column, show message box. Exit sub.

'Loop through items 0 through i in the list box, get value.
'Write value to active cell.

'Use offset to move to adjacent range on other sheet.
'Get the value in the same row.

'Back on the main sheet, offset one column to the left
'Write value to that cell.
'Continue loop to end.

'Select original active cell (or first row in selected range).

'Clear all of the box selections from the list box. Exit sub

Sub ListBox1_Keypress(ByVal KeyAscii As MSForms.ReturnInteger)

If KeyAscii <> 13 Then
  ClearBoxSelections
  Exit Sub
End If

Dim intActiveCol As Integer
Dim strWrongCol As String
Dim intAppCodeOffset As Integer
Dim strAppCodeVal As String
Dim strActiveColTitle
Dim selRange As Range

strWrongCol = "Please select a cell in the Tätigkeit column, and try again."

'Get active cell column; is cell address in correct column ("Tätigkeit")?

intActiveCol = ActiveCell.Column
strActiveColTitle = Sheets("Tabelle1").Range("C6").Offset(0, intActiveCol - 1).Value

If Not strActiveColTitle = "Taetigkeit" Then
  MsgBox strWrongCol
  ClearBoxSelections
  ActiveCell.Select
  Exit Sub
End If

'If not correct column, show msgbox "...select a cell in the Tätigkeit column."

If Not strActiveColTitle = "Taetigkeit" Then
  MsgBox strWrongCol
  ClearBoxSelections
  ActiveCell.Select
  Exit Sub
End If

Set selRange = Selection

For i = 0 To ListBox1.ListCount - 1
  If ListBox1.Selected(i) = True Then
    If strApps = "" Then
      strApps = ListBox1.List(i)
      intAppCodeOffset = i
      strAppCodeVal = Worksheets("Taetigkeiten").Range("A1").Offset(i, 0).Value
    Else
      strApps = strApps & ";#" & ListBox1.List(i)
      intAppCodeOffset = i
      strAppCodeVal = strAppCodeVal & ";#" & Worksheets("Taetigkeiten").Range("A1").Offset(i, 0).Value
    End If
  End If
Next

If strApps = "" Then
  MsgBox "Select at least one Tätigkeit."
  ActiveCell.Select
  Exit Sub
End If

Set selRange = selRange.Offset(0, -1)

With selRange
  selRange.Value = strAppCodeVal
End With

Set selRange = selRange.Offset(0, 1)

'Clear all of the box selections from the list box

ClearBoxSelections

ActiveCell.Select

End Sub

Maybe you have an idea what I am missing.

Thanks so much for your earlier reply

Elisabeth

You are calling a sub/function

ClearBoxSelections

on a number of occasions, but you don't have that sub/function.