GrößenProblem Dict? Rudi?

Function ops(ByVal rngA As Range)
Dim objKD As Object, objANR As Object
Dim rngC As Range
Dim i As Integer, j As Integer, iMax As Integer
Dim arrTmp, arrItems, arrNeu(), arrANR, arrANr2
Set objKD = CreateObject("Scripting.dictionary")   'Datensammler Kunden
Set objANR = CreateObject("Scripting.dictionary")   'Datensammler Auftragsnummern
For Each rngC In rngA.Columns(4).Cells '(Patienten ID)
If objKD.exists(rngC.Value) Then
arrTmp = objKD(rngC.Value)
ReDim arrNeu(UBound(arrTmp) + 1)
For i = 0 To UBound(arrTmp)
arrNeu(i) = arrTmp(i)
Next
arrNeu(i) = rngC.Offset(, 2).Value
objKD(rngC.Value) = arrNeu
iMax = WorksheetFunction.Max(iMax, UBound(arrNeu))
Else  'neuer Patient
objKD(rngC.Value) = Array(rngC.Offset(, -3).Value, rngC.Offset(, -2).Value, rngC.Offset(,  _
_
-1).Value, rngC.Value, _
rngC.Offset(, 1).Value, rngC.Offset(, 2).Value)
iMax = WorksheetFunction.Max(iMax, 6)
End If
'Auftragstypen 1er, 2er etc.
Select Case True  'rngC.Offset(, 2).Value
Case rngC.Offset(, 2).Value Like "8-98*"
objANR("8-98") = 0
Case Else
objANR(CInt(Split(rngC.Offset(, 2).Value, "-")(0))) = 0
End Select
Next rngC
arrItems = objKD.items
arrANR = objANR.keys
'Auftragstypen sortieren
For i = 0 To UBound(arrANR)
For j = i To UBound(arrANR)
If arrANR(j)  4) * objANR.Count) = arrTmp(j)
Next
arrANr2 = AnzANR(arrANR, arrTmp)
For j = 0 To UBound(arrANR)
arrNeu(i + 2, j + 6) = arrANr2(j)
Next
Next
ops = arrNeu
End Function

Function AnzANR(arrATyp, arrTmp)
Dim arrAnz()
Dim i As Integer, j As Integer
ReDim arrAnz(UBound(arrATyp))
For i = 0 To UBound(arrATyp)
arrAnz(i) = 0
For j = 5 To UBound(arrTmp)
Select Case True
Case arrATyp(i) = "8-98"
If arrTmp(j) Like "8-98*" Then
arrAnz(i) = arrAnz(i) + 1
End If
Case Else
If CInt(Split(arrTmp(j), "-")(0)) = arrATyp(i) Then
arrAnz(i) = arrAnz(i) + 1
End If
End Select
Next
Next
AnzANR = arrAnz
End Function