MultiSelect ListBox Значения для ячеек

Question

Я хочу иметь пользовательскую форму с множественным выбором ListBox. Каждое из выбранных значений ListBox должно создать новую ячейку с фактической датой и текстовым полем. Это то, что у меня есть до сих пор, но оно переписывает мои старые записи. Спасибо за вашу помощь!

Private Sub CommandButton1_Click()
Dim emptyRow As Long
Tabelle3.Activate
emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
    Dim ws As Worksheet
    Dim rng As Range
    Dim lng1 As Long
    Dim lng2 As Long
    Dim str() As String
    Set ws = ThisWorkbook.Worksheets("Essen")
    Set rng = ws.Range("A2")

    lng2 = 0 ' count of selected items
    For lng1 = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Selected(lng1) Then
            lng2 = lng2 + 1 ' increment counter
            ReDim Preserve str(1 To lng2) ' resize array...
            str(lng2) = Me.ListBox1.List(lng1) ' and add selected item

        End If

    Next lng1

    Cells(emptyRow, 1).Value = str(lng2)
    Cells(emptyRow, 2).Value = TextBox2.Value
    Cells(emptyRow, 3).Value = TextBox1.Value
    Cells(emptyRow, 4).Value = TextBox3.Value

    rng.Resize(lng2, 1).Value = Application.Transpose(str)

    UserForm1.Hide
End Sub