20.04.2016, 16:47 (Dieser Beitrag wurde zuletzt bearbeitet: 20.04.2016, 16:48 von atilla.)
Hallo Angelina,
dann müsste ich jetzt schreiben, dass ich Dich nicht richtig verstanden hatte.
Tue ich aber nicht. Besser ist, dann hast Du es falsch erklärt. :19:
Du hast Glück, dass ich meine eigene Handschrift im Code lesen konnte und dass ich so viele Kommentare reingeschrieben hatte.
Sonst hätte ich mich jetzt nicht so schnell wieder reindenken können.
In der Hoffnung, dass ich es jetzt richtig verstanden habe, sollte der folgende Code Deine Wünschen entsprechen.
Code:
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 = 2 To zz + 1
If .Cells(1, n) > 0 Then
Cells(i, 43) = .Cells(1, n)
Cells(i, 44) = .Cells(pp + 2, n)
Cells(i, 45) = .Cells(.Cells(pp + 3, n), 1) - lngZ
i = i + 1
End If
Next n
Mit den neuen Vorgaben, konnte ich den Code um min 7 Zeilen kürzen.
Sollte das auch nicht richtig sein, dann sende mir Deine Kontodaten. Denn dann ist es einfacher, wenn ich Dir die Summe des Lottojackpots überweise. :16:
Gruß Atilla
Folgende(r) 1 Nutzer sagt Danke an atilla für diesen Beitrag:1 Nutzer sagt Danke an atilla für diesen Beitrag 28 • Angelina