Problem mit dem Neudimensionieren eines Arrays

Hallo an alle Helfer!
Ich habe mal wieder ein Problem. Ich habe folgenden VBA-Code:

Private Sub CommandButton2_Click()
Dim rngSuchbereich      As Range
Dim intColumTherapeut   As Integer
Dim lngTermine          As Long
Dim strTermin()         As String
Dim strKasse()          As String
Dim Therapie1()         As String
Dim Therapie2()         As String
Dim Therapie3()         As String
Dim strAddresse         As String
Dim strColumn           As String
Dim arr()               As String
Dim lngEinträge         As Long
With Termine
'Suchen, in welcher Zeile die Überschriften stehen. Kriterium ist die Überschrift " _
Artikelnummer"
Set rngSuchbereich = Termine.Columns("D:W").Find(What:=ComboBox1, LookIn:=xlFormulas,  _
LookAt:=xlPart, MatchCase:=True)
If Not rngSuchbereich Is Nothing Then
lngTermine = rngSuchbereich.Row
strAddresse = rngSuchbereich.Address
Do
lngEinträge = lngEinträge + 1
strColumn = rngSuchbereich.Column
strTermin = Split(Termine.Cells(rngSuchbereich.Row, rngSuchbereich.Column), "-")
On Error Resume Next
Therapie1 = Split(strTermin(2), ":")
On Error GoTo 0
On Error Resume Next
Therapie2 = Split(strTermin(3), ":")
On Error GoTo 0
On Error Resume Next
Therapie3 = Split(strTermin(4), ":")
On Error GoTo 0
Select Case strColumn
Case 4
intColumTherapeut = 2
Case 7
intColumTherapeut = 4
Case 10
intColumTherapeut = 6
Case 13
intColumTherapeut = 8
Case 16
intColumTherapeut = 10
Case 19
intColumTherapeut = 12
Case 22
intColumTherapeut = 14
Case 25
intColumTherapeut = 16
Case 28
intColumTherapeut = 18
Case 31
intColumTherapeut = 20
End Select
ReDim arr(1 To 6, 1 To lngEinträge)
arr(1, lngEinträge) = Termine.Cells(rngSuchbereich.Row, 2)
arr(2, lngEinträge) = Format(Termine.Cells(rngSuchbereich.Row, 3), "hh:mm")
arr(3, lngEinträge) = Cells(2, intColumTherapeut)
'Wenn 3 Therapien eingetragen
If Therapie1(1) > "" And Therapie2(1) > "" And Therapie3(1) > "" Then
arr(4, lngEinträge) = Mid(Therapie1(1), 1, Len(Therapie1(1)) - 1) & ", "
arr(5, lngEinträge) = Mid(Therapie2(1), 1, Len(Therapie2(1)) - 1) & ", "
arr(6, lngEinträge) = Mid(Therapie3(1), 1, Len(Therapie3(1)) - 1)
'Wenn 2 Therapien eingetragen
ElseIf Therapie1(1) > "" And Therapie2(1) > "" Then
arr(4, lngEinträge) = Mid(Therapie1(1), 1, Len(Therapie1(1)) - 1) & ", "
arr(5, lngEinträge) = Mid(Therapie2(1), 1, Len(Therapie2(1)) - 1) & ", "
'Wenn 1 Therapie eingetragen
ElseIf Therapie1(1) > "" Then
arr(4, lngEinträge) = Mid(Therapie1(1), 1, Len(Therapie1(1)) - 1) & ", "
End If
Set rngSuchbereich = Termine.Columns("D:W").FindNext(rngSuchbereich)
Loop While Not rngSuchbereich Is Nothing And rngSuchbereich.Address <> strAddresse
End If
End With
With ListBox1
.Clear
.ColumnCount = 6
.ColumnWidths = "2cm; 1,5cm; 3cm; 1cm; 1cm; 1cm"
.List() = WorksheetFunction.Transpose(arr)
End With
End Sub