Code:
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Public arr()
Dim lngMax As Long
Sub zählen_Ati()
Dim lngLetzteZeile As Long, pp As Long, n As Long, lngP As Long, x, zz
Dim i As Long, j As Long
Dim strgSammlung As String
Dim vantQ As Variant
Dim lngZ As Long
Dim arrZ()
Dim vntF
Dim strgZ As String
Dim loStartTime As Long
loStartTime = GetTickCount
Tabelle1.Select
Application.ScreenUpdating = False
zählen
lngZ = Application.CountIf(Range("D:D"), ">0")
lngLetzteZeile = LetzteBeschriebeneZeile(Range("D:I"))
vantQ = Range("O1:AL" & lngLetzteZeile)
Columns("AN").ClearContents
Columns("N").Font.ColorIndex = xlAutomatic
For pp = 0 To lngMax - 1
For i = 1 To arr(pp) + 1
For j = 13 To 24
If vantQ(i, j) < 6 Then
If vantQ(i, j) - 1 + i > arr(pp) Or i = arr(pp) + 1 Then
If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
End If
Else
If vantQ(i, j) + i - 1 > arr(pp) Then
If InStr(1, strgSammlung, Format(vantQ(i, j - 12), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(vantQ(i, j - 12), "00")
End If
End If
Next j
Next i
If UBound(Split(strgSammlung, "#")) > 0 Then
Cells(arr(pp) + 1, 40) = UBound(Split(strgSammlung, "#"))
Cells(arr(pp) + 1, 14) = Replace(Join(Split(strgSammlung, "#"), ", "), ", ", "", 1, 1)
For n = 1 To UBound(Split(strgSammlung, "#"))
zz = Application.Max(zz, n)
ReDim Preserve arrZ(lngMax - 1, 0 To zz + 1)
x = Application.Match(CDbl(Split(strgSammlung, "#")(n)), Range(Cells(arr(pp) + 1, 4), Cells(arr(pp) + 1, 9)), 0)
If IsNumeric(x) Then
lngP = n * 3 + n - 3
Cells(arr(pp) + 1, 14).Characters(Start:=lngP, Length:=2).Font.ColorIndex = 3
arrZ(pp, 0) = arr(pp) + 1
arrZ(pp, n) = n
Else
arrZ(pp, n) = ""
End If
Next n
Else
Cells(arr(pp) + 1, 40) = 0
End If
strgSammlung = ""
strgZ = ""
Next pp
Columns("AQ:AS").ClearContents
With Sheets("Tabelle2")
.Cells.Clear
.Cells(2, 1).Resize(pp, zz) = (arrZ)
.Cells(1, 2).Resize(1, zz).FormulaLocal = "=Anzahl(B2:" & Cells(pp + 1, 2).Address(0, 0) & ")"
.Cells(pp + 2, 2).Resize(1, zz).FormulaLocal = "=Max(B2:" & Cells(pp + 1, 2).Address(0, 0) & ")"
.Cells(pp + 3, 2).Resize(1, zz).FormulaLocal = "=Vergleich(0;B1:" & .Cells(pp + 1, 2).Address(0, 0) & ";-1)"
vntF = .Cells(1, 1).Resize(pp + 3, zz + 1)
.Cells(1, 2).Resize(pp + 1, zz).Sort key1:=.Cells(1, 2), Order1:=xlDescending, Header:=xlNo, Orientation:=xlLeftToRight
i = 1
For n = 1 To lngMax
If .Cells(1, 2) > 0 Then
Cells(i, 43) = .Cells(1, 2)
Cells(i, 44) = Application.Max(.Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2)))
Cells(i, 43) = .Cells(1, 2)
.Cells(1, 2).Resize(pp + 1, 1).SpecialCells(xlCellTypeConstants).EntireRow.Delete
.Cells(1, 2).Resize(pp + 1, zz).Sort key1:=.Cells(1, 2), Order1:=xlDescending, Header:=xlNo, Orientation:=xlLeftToRight
i = i + 1
End If
Next n
.Cells(1, 1).Resize(pp + 3, zz + 1) = vntF
End With
For i = 1 To Application.Count(Columns("AR"))
With Sheets("Tabelle2")
Cells(i, 45) = .Cells(.Cells(pp + 3, Application.Match(Cells(i, 44), .Cells(pp + 2, 2).Resize(1, zz), 0) + 1), 1) - lngZ
End With
Next i
Erase arr
Erase arrZ
Application.ScreenUpdating = True
MsgBox "Laufzeit " & _
(GetTickCount - loStartTime) / 1000 & " Sekunden.", _
vbInformation, "Application.Wait Soll: 3 Sekunden"
End Sub