Rangliste

[freddy]

Servus Excelaner,
Habe ein Problem mit einer kleinen VBA Rangliste die soweit auch funktioniert
außer bei Punkte Gleichheit da wir der jeweils nachfolgende Name nicht mehr Angezeigt sondern immer zwei oder bei mehreren
Gleichheiten der zuerst in der Spalte angegebene Name

Vielleicht kann mir jemand weiter helfen

         For i = 1 To 6
            WertMax7 = Application.WorksheetFunction.Large(.Range(.Cells(3, 4), Cells(3, 14)), i)
         .Cells(i + 42, 19) = WertMax7
        Set BestAdr = Bereich.Find(WertMax7)
        .Cells(i + 42, 24) = .Cells(BestAdr.Row + 1, BestAdr.Column)
Next i

Punkte ------------------------NAME
9 Manfred
7 Alois
5 Georg
5 Georg<>Wolfgang<<>>>so wäre es Richtig und OK
3 Franz
2 Erich

[schauan]

Hallöchen,

ich bin hier mal etwas von Deinem Beispiel weggegangen und habe folgenden Vorschlag. Die Daten werden in ein Array eingelesen, dort sortiert und an anderer Stelle ausgegeben.

Code:

Function BubbleSort(ByRef strArray As Variant) As Variant()
'Sortieren eines eindimensionalen Array
'Variablendeklarationen
'Long
Dim iCnt1&, iCnt2&
'Variant
Dim strWert
'Schleife 1 ueber Arrayeintraege
For iCnt1 = UBound(strArray) - 1 To LBound(strArray) Step -1
  'Schleife 2 ueber Arrayeintraege
  For iCnt2 = LBound(strArray) To iCnt1
    'Wenn der großgeschriebene Inhalt des Arrays hoeherwertig ist
    'als der Folgeeintrag, dann
    If LCase(strArray(iCnt2)) > LCase(strArray(iCnt2 + 1)) Then
      'Inhalte austauschen
      'Inhalt zwischenspeichern
      strWert = strArray(iCnt2)
      'bisherigen Inhalt mit Folgewert ueberschreiben
      strArray(iCnt2) = strArray(iCnt2 + 1)
      'Zwischengespeicheten Inhalt als Folgewert uebernehmen
      strArray(iCnt2 + 1) = strWert
    'Ende Wenn der großgeschriebene Inhalt des Arrays hoeherwertig ist...
    End If
  'Ende Schleife 2 ueber Arrayeintraege
  Next
'Ende Schleife 1 ueber Arrayeintraege
Next
BubbleSort = strArray
End Function

Sub test()
'Variablendeklarationen
'Variant-Array
Dim arrTmp, arrTmp2()
'Integer
Dim iCnt%
'Daten aus begrenztem Bereich uebernehmen
arrTmp = Range("a1:b6")
'zweites Array dimensionieren
ReDim Preserve arrTmp2(1 To UBound(arrTmp))
'Schleife ueber Arrayeintraege
For iCnt = LBound(arrTmp, 1) To UBound(arrTmp, 1)
  'Zusammenfassen der Eintraege zu einem String mit definiertem Trennzeichen "#"
  arrTmp2(iCnt) = arrTmp(iCnt, 1) & "#" & arrTmp(iCnt, 2)
'Ende Schleife ueber Arrayeintraege
Next
'Mit dem Zielbereich
With Range("D1:D6")
  'Werte sortieren und uebernehmen
  .Value = WorksheetFunction.Transpose(BubbleSort(arrTmp2))
  'Eintraege mit "Text in Spalten" am "#" trennen
  .TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="#", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
'Ende Mit dem Zielbereich
End With
End Sub

[freddy]

Danke für die Hilfe muss das ganze versuchen
aber wenn ich ehrlich bin habe ich sehr wenig Ahnung von Functionen ich weiß nicht wie ich das ganze zum laufen bringe
vielleicht kannst Du mir auf die Füße helfen

[freddy]

Servus Andre
habe mal die Tabelle hinzugefügt um die es [attachment=5708] geht
Es sind die Daten  aus D3 - N3

Danke

[freddy]

Code:

Sub SechsBesteErgebnise()
   Dim Rang%, msg$, Msg1$, Msg2$, Msg3$, Msg4$, Msg5$, Msg6$, _
      Bestwerte As Double, BestAdr As Range, VonPlatz%, BisPlatz%, Bereich$, Bereich1
   With Sheets("Tipp_Auswertung")
     
      Bereich = "D3:N3"
      Set BestAdr = .Range(Bereich).Cells(1)
     
      VonPlatz = 1
      BisPlatz = 6
      On Error GoTo Ende
      For Rang = VonPlatz To BisPlatz
        
         Bestwerte = Application.WorksheetFunction.Large(.Range(Bereich), Rang)
         Set BestAdr = .Range(Bereich).Find(After:=BestAdr, What:=Bestwerte, LookIn:=xlValues)
        
         .Cells(Rang + 50, 4) = CStr(Rang)
         .Cells(Rang + 50, 5) = ".Platz ="
         .Cells(Rang + 50, 6) = Bestwerte
         .Cells(Rang + 50, 7) = " Punkte"
         .Cells(Rang + 50, 8) = .Cells(BestAdr.Row + 1, BestAdr.Column)
        
         msg = msg & Space(4) & CStr(Rang) & Space(3) & ".Platz =" _
            & Space(6) & Bestwerte & Space(3) & " Punkte" & Space(6) & .Cells(BestAdr.Row + 1, BestAdr.Column) & vbLf
        
      Next Rang
Ende:
      MsgBox msg
   End With
  
End Sub

Nun hab ich es doch noch Hinbekommen das auch bei gleichen Ergebnisen alle Namen Angezeigt werden :18:

[schauan]

Hallo Freddy,
Schön, das du es hinbekommen hast. Bin derzeit etwas gehandycapt, daher noch keine Antwort von mir...

[freddy]

Code:

Sub Tipp_Rangliste()
  Dim Rang%, msg$, BestWerte As Double, BestAdr As Range, VonPlatz%, BisPlatz%, Bereich$, Bereich1
  With Sheets("Tipp_Auswertung")
 

     Bereich = "D3:N3"
     Set BestAdr = .Range(Bereich).Cells(1)
     
     VonPlatz = 1
     BisPlatz = 6
     On Error GoTo Ende
     For Rang = VonPlatz To BisPlatz
       
        BestWerte = Application.WorksheetFunction.Large(.Range(Bereich), Rang)
        Set BestAdr = .Range(Bereich).Find(After:=BestAdr, What:=BestWerte, LookIn:=xlValues)
       
    If BestWerte > 0 Then
        .Cells(Rang + 50, 4) = "den" & Space(6) & CStr(Rang) & "."
        .Cells(Rang + 50, 5) = "Platz mit"
        .Cells(Rang + 50, 6) = BestWerte
        .Cells(Rang + 50, 7) = " Saison Punkte belegt --->"
        .Cells(Rang + 50, 9) = .Cells(BestAdr.Row + 1, BestAdr.Column)
       
        msg = msg & Space(4) & "den  " & CStr(Rang) & ".  " & Space(3) & "Platz mit ---->" _
           & Space(6) & BestWerte & Space(3) & " Punkten belegt ---> " & Space(6) & .Cells(BestAdr.Row + 1, BestAdr.Column) & vbLf
     End If
     Next Rang
     
Zeile = 56

For i = 51 To Zeile
  Cells(i, 4) = "den " & Space(6) & Application.WorksheetFunction.Rank _
    (Cells(i, 6), Range(Cells(51, 6), Cells(Zeile, 6))) & "."
Next i
Range("I51", Cells(Zeile, 9)).Sort Key1:=Range("F51"), Order1:=xlDescending

Ende:
   '  MsgBox msg
  End With
PlazierungsBeschriftung
End Sub

Servus Andre

Trotzdem Herzlichen Dank für Deine Hilfe

Der Code erfüllt absolut seinen Zweck außer wenn die 6 Einträge nicht vollständig sind "Beispiel 4 von 6 haben Werte dann

Stimmt die Ranglisten Reihen Folge nicht mehr wie unten zu sehen ist was sich aber nach einigen Spieltagen von selbst Erledigen wird
Wäre aber Interessant dahinter zu kommen wieso das so ist bisher ist es mir nicht gelungen aber vielleicht weist ja Du wie man das lösen könnte

den       1. Platz mit 3 Saison Treffer belegt ---> Erich
den       1. Platz mit 3 Saison Treffer belegt ---> Franz
den       1. Platz mit 3 Saison Treffer belegt ---> Georg
den       1. Platz mit 3 Saison Treffer belegt ---> Manfred  
den       1. Platz mit 3 Saison Treffer belegt ---> Wolfgang
den       1. Platz mit 3 Saison Treffer belegt ---> Alois

den      1. Platz mit 2 x Zwei Punkte belegt ---> Wolfgang
den      2. Platz mit 1 x Zwei Punkte belegt ---> Erich
den      3. Platz mit 1 x Zwei Punkte belegt ---> Georg
den      4. Platz mit 1 x Zwei Punkte belegt ---> Manfred  


den 1. Platz mit 2 x Zwei Punkte belegt ---> Wolfgang

den 2. Platz mit 1 x Zwei Punkte belegt ---> Erich <-_-_-_-_-_-_ So müsste es eigentlich aussehen

den 2. Platz mit 1 x Zwei Punkte belegt ---> Georg <-_-_-_-_-_-_ So müsste es eigentlich aussehen

den 2 Platz mit 1 x Zwei Punkte belegt ---> Manfred <-_-_-_-_-_-_ So müsste es eigentlich aussehen











:18: :18: :18:

[schauan]

Hallo Freddy,

warum kann ich Dir auch nicht gerade erklären, ausser, das die Schleife eben 6 durchgänge hat und sich da Excel was zusammensucht.
Du müsstest also schauen, wie Du die 6 "reduzierst", z.B. statt
BisPlatz = 6
in
BisPlatz = 4

Du könntest mit worksheetfunction.counta die Einträge im betreffenden Bereich der Zeile 3 zählen und BisPlatz zuweisen.

[freddy]

Servus Andre,

Genau das war es mit CountA den Zähler zu ermitteln dann Klappt die Reihenfolge Danke Dir für den Tipp
Manchmal hat man halt ein Brett vorm Kopf