Ursprüngliche Zahlen finden?

[Angelina]

hallo atilla,


:18: 

DANKE DANKE DANKE :100: 


:45:

Vielen lieben Dank - alles perfekt so !


LG
Angelina

[Angelina]

hallo Atilla,

muß dich nochmals stören  


Mir ist ein Fehler aufgefallen.

Ich habe die Datei nochmals angehängt.
Letzter Stand der Datei.

Also, wenn ich in Spalte AO alle Zahlen summiere komme ich in der Musterdatei
auf 137

Wenn ich nun in der Spalte AQ alle Zahlen summiere komme ich in der Musterdatei
auf 84

Die 137 stimmen ... bei den 84 fehlen einige.

Die Spalte AR zählt auch nur die Trefferposition -
also rote Zahlen aus Spalte N - bis zur Position 11

Es gibt aber ... auch in dieser Musterdatei ... Positionen
wie z.B. die Zeile 28 oder 29 wo in der Spalte N die
Position 13 oder 14 rot ist.

Da denke ich liegt der kleine Fehler ... es werden nicht alle
Positionen in der Spalte AR dargestellt.

Könntest du da bitte nochmals drüberschauen?

Danke nochmals

LG
Angelina

[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

End With


Erase arr
Erase arrZ
Application.ScreenUpdating = True
MsgBox "Laufzeit " & _
(GetTickCount - loStartTime) / 1000 & " Sekunden.", _
 vbInformation, "Application.Wait Soll: 3 Sekunden"

End Sub

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:

[Angelina]

hallo atilla,
ja ... mein Fehler
Danke ... Danke ...
ist richtig so !!!
LG
Angelina