05.10.2023, 10:00 (Dieser Beitrag wurde zuletzt bearbeitet: 05.10.2023, 10:00 von dertommy.)
Hallo Egon12!
Danke sehr für deine schnell Antwort, es funktioniert super mit der Anzahl.
Leider musste ich noch etwas feststellen. In der MsgBox werden zwar im unteren Teil der MsgBox die Ränge nicht doppelt angezeigt, aber dafür im oberen. Dort wird der Rang 6 doppelt angezeigt.
Ich habe die Datei wieder mitgeschickt. Vielleicht könntest du mir bitte nochmals helfen.
So, es funktioniert tatsächlich nicht. Anbei die Datei.
ja, das ist logisch.
Schau mal - die ursprüngliche Prozedur hatte nur das Problem, dass falsch zugeordnete gleiche Werte im 2. Teil auftauchten, welche gleich aussahen aber nicht gleich waren. Das war das Grundproblem dieser Prozedur.
Mit meiner Lösung sind dieser Fehler und auch noch ein paar andere Ungereimtheiten, welche in dieser Vorgehensweise enthalten waren, mit beseitigt.
Diese Dinge sind dir nur bisher auf Grund der Datenlage nicht aufgefallen.
Was ich nicht verarbeitet habe ist, wenn tatsächlich identische Werte (Formelergebnisse) enthalten sind.
Wie soll mit völlig identischen Formelausgaben vorgegangen werden.
Soll der zufällig erste Treffer abgebildet werden und die anderen weg.
Wie soll dann die folgende Nummerierung aussehen.
Da wäre es logisch, dass wenn beispielhaft an 4. Position 2 exakt Gleiche enthalten sind, um es auswertbar zu halten, dann die Folge 1 /2 / 3 / 4 / 6 ... sein müsste, um zu zeigen, dass 2x Gleichstand in 4 vorhanden ist.
Besser auswertbar wäre es aber so wie ich es dir zusammengestellt hatte.
Lineares Durchnummerieren sehe ich als Fehler an, da damit die Doppelungen nicht mehr auswertbar sind.
Denke erst mal in Ruhe darüber nach, bevor ich die die paar Codezeilen noch reinsetzte.
Ich hätte es gerne so gelöst, dass die Ränge einfach von 1 - 8 angezeigt werden, mit den richtigen Daten. Es soll eben kein Rang doppelt angezeigt werden, aber die Beträge schon und das richtige Jahr dazu. So wie es bei munteren Block auch funktioniert.
Oder verstehe ich nicht ganz, was du meinst?
Eigentlich ist das so falsch. Deine Formeln geben das Ranking eigentlich korrekt aus, denn von da Stammen die Rankingnummern.
Es werden mit dem 3-Zeiler:
Code:
For i = 1 To UBound(arrList2)
arrList2(i, 2) = i
Next i
die Nummern durchlaufend neu zugewiesen.
eingebaut dann so:
Code:
Option Explicit
Sub JahresstatistikRanking()
Dim arrList(), arrList1(), arrList2(), arrTmp1(), arrTmp2(), iTemp, i&, j&, k&, Text1$, Text2$
arrList = Tabelle10.Range("A3:Q" & Tabelle10.Cells(Rows.Count, 1).End(xlUp).Row) ' Array laden Spalte A bis Q
arrList1 = Application.Index(arrList, Evaluate("row(1:" & UBound(arrList, 1) & ")"), Array(1, 16, 15, 17)) ' Übergabe der Spalte 1(A), 16(P),15(O),17(Q)
arrList2 = Application.Index(arrList, Evaluate("row(1:" & UBound(arrList, 1) & ")"), Array(1, 8, 12, 13)) ' Übergabe der Spalte 1(A), 8(H),12(L),13(M)
For i = 1 To UBound(arrList1)
If arrList1(i, 3) > 0 Then ' Filtern des Array auf vorhandenen Betrag
j = j + 1
ReDim Preserve arrTmp1(1 To 4, 1 To j)
arrTmp1(1, j) = Year(arrList1(i, 1))
arrTmp1(2, j) = arrList1(i, 2)
arrTmp1(3, j) = arrList1(i, 3)
arrTmp1(4, j) = arrList1(i, 4)
End If
If arrList2(i, 3) > 0 Then
k = k + 1
ReDim Preserve arrTmp2(1 To 4, 1 To k) ' Filtern des Array auf vorhandenen Betrag
arrTmp2(1, k) = Year(arrList2(i, 1))
arrTmp2(2, k) = arrList2(i, 2)
arrTmp2(3, k) = arrList2(i, 3)
arrTmp2(4, k) = arrList2(i, 4)
End If
Next i
ReDim Preserve arrTmp1(1 To 4, 1 To j)
ReDim Preserve arrTmp2(1 To 4, 1 To k)
arrList1 = Application.Transpose(arrTmp1)
For k = 1 To UBound(arrList1)
For i = 1 To UBound(arrList1) - 1 ' Sortieren der Rangnummern aufsteigend
If arrList1(i, 2) > arrList1(i + 1, 2) Then
For j = 1 To UBound(arrList1, 2)
iTemp = arrList1(i, j)
arrList1(i, j) = arrList1(i + 1, j)
arrList1(i + 1, j) = iTemp
Next j
End If
Next i
Next k
For i = 1 To UBound(arrList1) ' Aufbereiten des Textblockes mit Zeilenumbruch
Text1 = Text1 & arrList1(i, 2) & ". Rang: Jahr: " & arrList1(i, 1) & ": € " & Format(arrList1(i, 3), "#,##0.00") & " (" & arrList1(i, 4) & " Auszahlungen)" & vbLf
If i = 8 Then Exit For
Next i
Text1 = Left(Text1, Len(Text1) - 1)
arrList2 = Application.Transpose(arrTmp2)
For k = 1 To UBound(arrList2)
For i = 1 To UBound(arrList2) - 1 ' Sortieren der Rangnummern aufsteigend
If arrList2(i, 2) > arrList2(i + 1, 2) Then
For j = 1 To UBound(arrList2, 2)
iTemp = arrList2(i, j)
arrList2(i, j) = arrList2(i + 1, j)
arrList2(i + 1, j) = iTemp
Next j
End If
Next i
Next k
For i = 1 To UBound(arrList2)
arrList2(i, 2) = i
Next i
For i = 1 To UBound(arrList2) ' Aufbereiten des Textblockes mit Zeilenumbruch
If Year(DateSerial(arrList2(i, 1), 1, 1)) = CDbl(Year(Date)) Then
Text2 = Text2 & arrList2(i, 2) & ". Rang: Jahr: " & arrList2(i, 1) & ": € " & Format(arrList2(i, 3), "#,##0.00") & " (" & arrList2(i, 4) & " Auszahlungen)" & " - aktuelles Jahr" & vbLf
If i = 8 Then Exit For
Else
Text2 = Text2 & arrList2(i, 2) & ". Rang: Jahr: " & arrList2(i, 1) & ": € " & Format(arrList2(i, 3), "#,##0.00") & " (" & arrList2(i, 4) & " Auszahlungen)" & vbLf
If i = 8 Then Exit For
End If
Next i
Text2 = Left(Text2, Len(Text2) - 1)
' Ausgabe in Textbox
MsgBox "Top " & " (berechnet bis Jahresende)" & vbLf & vbLf & Text2 & vbLf & vbLf & _
"Top " & UBound(arrList2) & " (berechnet bis heute (" & Format(Date, "dd.mm") & ".XXXX" & "))" & _
vbLf & vbLf & Text1, , "Ranking der Auszahlungen"
End Sub
Danke für dem Code, daweil schaut es gut aus. Das heißt aber, dass meine Formeln für die Ränge für die MsgBox eigentlich keine Rolle mehr spielen oder? Ich habe nämlich die Spalt H gelöscht, wo auch Ränge ermittelt werden und die Ränge werden trotzdem in der MsgBox angezeigt. Wenn ich aber hingegen die Spalte P lösche, werden die Ränge in der MsgBox im unteren Teil nicht mehr angezeigt.
Die Formel nicht raus Löschen. Das dies so klappt ist purer Zufall und nur der momentanen Datenlage der Tabelle geschuldet.
Wenn du den Code mit F8 händisch Step by Step durchgehst und im Direktfenster schaust was sich wie ändert wirst du sehen, dass zum Sortieren der Ränge genau diese Formeln (Rankingausgabe) herangezogen werden.
Das was ich dir zusammengestellt habe benötigt definitiv die in deiner hochgeladenen Datei vorgefundenen Formelausgaben in den Auswertungspalten.
Ich wollte mich nochmals bei dir bedanken, nämlich für deine ausführlichen Beschreibungen und deine Hilfestellungen. Da weil funktioniert der Code super.
Ich hätte aber noch ein Anliegen an dich, welches mir erst jetzt eingefallen ist.
Wenn du die mit angehängte Datei öffnest und die MsgBox ansiehst, sieht man das aktuelle Jahr 2023 nicht, da es nicht in die Ränge 1 - 8 fällt. Ich hätte nun gerne, dass wenn das "aktuelle Jahr" nicht in die Ränge 1 - 8 fällt, dass es trotzdem angezeigt wird, nämlich unterhalb vom letzten Rang mit einer Leerzeile (und das für den oberen und unteren Block), nämlich mit dem dazugehörigen Rang, Jahr, Betrag und Anzahl der Auszahlungen.
In meinem Beispiel müsste es dann im oberen und unteren Teil jeweils der 10. Rang, Jahr 2023: € 6,00 (1 Auszahlung) sein.
Ich hoffe, dass du dich auskennst und dass du mir nochmals helfen kannst.
06.10.2023, 13:46 (Dieser Beitrag wurde zuletzt bearbeitet: 06.10.2023, 13:50 von Egon12.)
Hallo,
Es ist eigentlich nicht schwer.
Du musst im Elsezweig (Befüllen von Text1) eine weitere Abfrage einbauen.
Erforderlich sind 2 Bedingungen:
Der 8. Schleifendurchlauf ist erreicht und in Text1 fehlt das aktuelle Jahr.
Der 8 Schleifendurchlauf --> i=8
Prüfung auf das fehlende aktuelle Jahr --> InStr(1, Text1, Year(Date), vbTextCompare) = 0
Also so:
Code:
' hier abgleichen
If InStr(1, Text1, Year(Date), vbTextCompare) = 0 And i = 8 Then ' Prüfung auf veorhandensein des aktuellen Jahres im letzten Schleifendurchlauf
For j = 1 To UBound(arrList1)
If Year(DateSerial(arrList1(j, 1), 1, 1)) = CDbl(Year(Date)) Then
Text1 = Text1 & "8. Rang: Jahr: " & arrList1(j, 1) & ": € " & Format(arrList1(j, 3), "#,##0.00") & " (" & arrList1(j, 4) & " Auszahlungen)" & " - aktuelles Jahr" & vbLf
End If
Next j
Exit For
Else
Text1 = Text1 & arrList1(i, 2) & ". Rang: Jahr: " & arrList1(i, 1) & ": € " & Format(arrList1(i, 3), "#,##0.00") & " (" & arrList1(i, 4) & " Auszahlungen)" & vbLf
Anz1 = Anz1 + 1
If i = 8 Then Exit For
End If
Suche die korrekte Stelle mal selbst und füge diese If/Else Abfrage da ein.
Wenn du den Code mal mit F8 durchgehst, findest du recht schnell die Stelle.
Danke wieder mal für deine Bemühungen. Ich hätte es probiert, deinen Code einzubinden, aber jetzt zeigt er mir die Ränge von 1 - 8 alle doppelt an. Wahrscheinlich habe ich auch was falsch gemacht. Hier mein aktuelle Codestelle:
Code:
For i = 1 To UBound(arrList1) ' Aufbereiten des Textblockes mit Zeilenumbruch
If Year(DateSerial(arrList1(i, 1), 1, 1)) = CDbl(Year(Date)) Then
Text1 = Text1 & arrList1(i, 2) & ". Rang: Jahr: " & arrList1(i, 1) & ": € " & Format(arrList1(i, 3), "#,##0.00") & " (" & arrList1(i, 4) & " Auszahlungen)" & " - aktuelles Jahr" & vbLf
Anz1 = Anz1 + 1
If i = 8 Then Exit For
Else
If InStr(1, Text1, Year(Date), vbTextCompare) = 0 And i = 8 Then ' Prüfung auf veorhandensein des aktuellen Jahres im letzten Schleifendurchlauf
For j = 1 To UBound(arrList1)
If Year(DateSerial(arrList1(j, 1), 1, 1)) = CDbl(Year(Date)) Then
Text1 = Text1 & "8. Rang: Jahr: " & arrList1(j, 1) & ": € " & Format(arrList1(j, 3), "#,##0.00") & " (" & arrList1(j, 4) & " Auszahlungen)" & " - aktuelles Jahr" & vbLf
End If
Next j
Exit For
Else
Text1 = Text1 & arrList1(i, 2) & ". Rang: Jahr: " & arrList1(i, 1) & ": € " & Format(arrList1(i, 3), "#,##0.00") & " (" & arrList1(i, 4) & " Auszahlungen)" & vbLf
Anz1 = Anz1 + 1
If i = 8 Then Exit For
End If
Text1 = Text1 & arrList1(i, 2) & ". Rang: Jahr: " & arrList1(i, 1) & ": € " & Format(arrList1(i, 3), "#,##0.00") & " (" & arrList1(i, 4) & " Auszahlungen)" & vbLf
Anz1 = Anz1 + 1
If i = 8 Then Exit For
End If
Next i
Text1 = Left(Text1, Len(Text1) - 1)
Ich hoffe, dass du mir nochmals weiterhelfen kannst.
