Kommentar aus Zelle in Textbox

Bräuchte mal wieder Hilfe von den Profis,
mit einem Code schreibe ich Daten aus einer Userform mit diversen Textboxen in die Tabelle. Den Code habe ich jetzt dahingehend erweitert, dass ich noch einen Text in einer Textbox erfassen und diesen dann als Kommentar in die Zelle schreibe. Der Kommentar ist immer in einer Zelle in der Spalte D. Das funktioniert auch. Hier der Code-Teil mit dem ich den Kommentar in die Zelle schreibe:
With ActiveCell
.ClearComments
If Dateneingabe.Bemerkungen <> "" Then
.AddComment Dateneingabe.Bemerkungen.Text
.Comment.Shape.DrawingObject.AutoSize = False
.Comment.Shape.Width = 700
.Comment.Shape.Height = 400
End If
End With
Dateneingabe.Bemerkungen = ""
Im weiteren Verlauf lese ich dann die Daten aus der Tabelle über ein Array in eine mehrspaltige Listbox ein.

Private Sub UserForm_Activate()
Application.ScreenUpdating = False
Dim sText As String
Dim i As Long, n As Long, r As Long
Dim ArValues()
Dim arrList()
Worksheets("Jahrestabelle").Activate
TextBox1.SetFocus
Personalien.Clear
Änderung.Ändern.ForeColor = RGB(0, 100, 0)
Änderung.Löschen.ForeColor = RGB(255, 0, 0)
With Worksheets("Jahrestabelle")
i = .Range("D1000").End(xlUp).Row
If i > 4 Then
sText = .Cells(i, 4).Value & .Cells(i, 5).Value & .Cells(i, 6).Value
'Array groß genug Dimensionieren
ReDim Preserve ArValues(1 To 12, 1 To i)
For i = 5 To i
If Trim(CStr(.Cells(i, 4).Value)) <> "" Then
n = n + 1 'Hilfszähler um Array zu füllen
ArValues(1, n) = .Cells(i, 4).Value
ArValues(2, n) = .Cells(i, 5).Value
ArValues(3, n) = .Cells(i, 6)
ArValues(4, n) = .Cells(i, 7).Value
ArValues(5, n) = .Cells(i, 8)
ArValues(6, n) = .Cells(i, 9)
ArValues(7, n) = .Cells(i, 10)
ArValues(8, n) = .Cells(i, 11)
ArValues(9, n) = .Cells(i, 12)
ArValues(10, n) = .Cells(i, 13)
ArValues(11, n) = i
ArValues(12, n) = .Cells(i, 4).NoteText
End If
Next i
'nicht benötigte Spalten entfernen
ReDim Preserve ArValues(1 To 12, 1 To n)
ReDim arrList(1 To n, 1 To 12)
'Array drehen und in Listbox schreiben
For r = 1 To 12
For i = 1 To n
arrList(i, r) = ArValues(r, i)
Next
Next
Me.Personalien.List = arrList
End If
End With
Worksheets("Dateneingabe").Activate
Application.ScreenUpdating = True
End Sub