30.09.2023, 07:37 (Dieser Beitrag wurde zuletzt bearbeitet: 30.09.2023, 07:40 von Egon12.)
Hallo,
kein Problem:
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 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
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
Next i
Text1 = Left(Text1, Len(Text1) - 1)
arrList2 = Application.Transpose(arrTmp2)
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
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
Else
Text2 = Text2 & arrList2(i, 2) & ". Rang: Jahr: " & arrList2(i, 1) & ": € " & Format(arrList2(i, 3), "#,##0.00") & " (" & arrList2(i, 4) & " Auszahlungen)" & vbLf
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
Eine Frage hätte ich doch noch an dich. Du benutzt Office2016 und lädst die Demodatei als .xls statt .xlsm hoch. Warum?
Die Stellen, wo eventuelle spätere Anpassungen nötig sind, habe ich mit einem Kommentar versehen.
04.10.2023, 08:52 (Dieser Beitrag wurde zuletzt bearbeitet: 04.10.2023, 08:53 von dertommy.)
Hallo Egon12!
Danke sehr für deinen Code, in meiner Beispieldatei funktioniert er wunderbar.
Wenn ich ihn nun aber in meine Original Datei kopiere, werden auf einmal alle Ränge angezeigt, was er vorhin nicht gemacht. Vorher hat er mir nur die ersten 8 Ränge angezeigt und auch nur dann, wenn die Summe (Betrag in €) mehr als 0 war. Es wäre super, wenn du mir noch helfen könntest.
Anbei nochmals mein alter Code, vielleicht hilft er:
Code:
Sub JahresstatistikRanking()
With ThisWorkbook.Worksheets("Jahresstatistik")
Dim i, i1, WWert, WWert1 As Double, TText, TText1 As String, Zeile, Zeile1 As Integer, Sp, Sp1, Rang, Rang1 As Integer
Dim Z1 As Integer, LR, LR1 As Integer, rng, rng1 As Range, Jahr, Jahr1 As Integer, TMP, TMP1 As String
Z1 = 3 'Erste Datenzeile
Sp = 12 'Werte in L
Sp1 = 15 'Werte in O
LR = Cells(Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte
LR1 = Cells(Rows.Count, Sp1).End(xlUp).Row 'letzte Zeile der Spalte
04.10.2023, 09:58 (Dieser Beitrag wurde zuletzt bearbeitet: 04.10.2023, 09:58 von dertommy.)
Hallo!
Danke sehr für deine rasche Rückmeldung. Ich habe nun deinen alten und auch neuen Code nicht mehr in eine Testdatei sondern in die Original eingebunden und da ist es so, dass die Ränge durcheinander sind. Ich habe dir die Datei wieder so hergerichtet. In der Testdatei funktioniert dein Code und die Ränge werden korrekt angezeigt.
Ich hoffe, dass du mir nochmals helfen kannst.
04.10.2023, 10:21 (Dieser Beitrag wurde zuletzt bearbeitet: 04.10.2023, 11:15 von Egon12.)
Hallo,
teste mal ob nun klappt.
Es ist, da du leider unzureichende Daten mitgegeben hast, für außenstehende schwer zu erraten, ob es so ausreicht.
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) ' 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
04.10.2023, 10:29 (Dieser Beitrag wurde zuletzt bearbeitet: 04.10.2023, 10:35 von dertommy.)
Hallo!
Danke sehr, jetzt werden zwar die Ränge wieder korrekt angezeigt, aber es werden nun wieder alle Ränge angezeigt, was ich nicht will. Ich will nur die ersten 8 Ränge unter der Bedingung, dass der Betrag im Jahr größer als 0 ist, angezeigt bekommen.
Hallo!
Habe gerade dein neues Kommentar gesehen und deinen neuen Code genommen. Wenn ich ihn nun in meine Original Datei einbinde, fängt er nun mit dem Rang 10 bis 17 an. Ich hätte aber gerne die ersten 8 (1. - 8 Rang) Ränge angezeigt bekommen.
Das tut mir leid, dass ich unzureichende Daten mitgeliefert habe. Da es nur ein Auszug aus meiner Original Datei ist, dachte ich, dass es keinen Unterschied macht, ob 5 Jahre oder mehr Jahre vorhanden sein müssen.
Jetzt funktioniert es auf jeden Fall mit deinem Code.
Eine Bitte hätte ich noch: In der Msgbox gibt es folgende Codestelle:
Code:
"Top " & UBound(arrList2)
Diese liefert immer den gesamte Anzahl der Liste zurück. Ich hätte aber gerne, dass sich der Anzahl auf die angezeigten Jahre in der MsgBox bezieht. Heißt, dass es wenn in der MsgBox nur 5 Jahre angezeigt werden, dass nur die Zahl 5 steht. Nachdem wir ja eine Einschränkung auf 8 Jahre in der MsgBox haben, darf dann auch bei der Anzahl max. die 8 stehen. Sprich, würde es insgesamt 17 Jahre geben und in der MsBox werden nur 8 Jahre angezeigt, darf dann auch nur 8 stehen.
Ich hoffe, dass du weißt was ich meine und dass du mir nochmals weiterhelfen kannst.
das kann man indem man statt die Zeilenzahl des Arrays auszuwerten einfach eine Zählvariable einsetzt. Das hättest sicherlich auch du feststellen/entdecken können.
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
k = 0
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
k = k + 1
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
k = k + 1
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 " & k & " (berechnet bis heute (" & Format(Date, "dd.mm") & ".XXXX" & "))" & _
vbLf & vbLf & Text1, , "Ranking der Auszahlungen"
End Sub
