Array Code versagt

Sub ZiffernSammlung()
Application.Calculation = xlCalculationManual
Dim Einträge As Single, SchleifenZahl As Single, Zähler As Single
Dim SammlungNr1 As Integer, SammlungNr2 As Integer, SammlungTreffer As Single
Dim SammlungArr() As Variant
Einträge = WorksheetFunction.Count(Columns(Range("A:A").Column))
SchleifenZahl = WorksheetFunction.Combin(Einträge, 2)
SammlungTreffer = 0
ReDim SanmmlungArr(1 To Einträge)
' startet die Suche
For Zähler = 1 To SchleifenZahl
If Range("BH1").Offset(Zähler, 0).Value = "" Then
Else
' notiert die Ziffern der Fundstelle
SammlungNr1 = CInt(Left(Range("BH1").Offset(Zähler, 0).Value, _
WorksheetFunction.Find(Chr(6), Range("BH1").Offset(Zähler, 0).Value) - 1))
SammlungNr2 = CInt(Right(Range("BH1").Offset(Zähler, 0).Value, _
Len(Range("BH1").Offset(Zähler, 0).Value) - _
WorksheetFunction.Find(Chr(6), Range("BH1").Offset(Zähler, 0).Value)))
End If
If SammlungArr(SammlungNr1) = 0 And SammlungArr(SammlungNr2) = 0 Then
' SammlungTreffer hochzählen
SammlungTreffer = SammlungTreffer + 1
' gefundene Werte ins SammlungArray aufnehmen
SammlungArr(SammlungNr1) = SammlungNr1
SammlungArr(SammlungNr2) = SammlungNr2
End If
Next Zähler
Application.Calculation = xlCalculationAutomatic
End Sub