Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Rangliste
#1
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
Grüße
aus dem schönen Bayern

Freddy

Excel 2013 Win8
Antworten Top
#2
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
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#3
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
Grüße
aus dem schönen Bayern

Freddy

Excel 2013 Win8
Antworten Top
#4
Servus Andre
habe mal die Tabelle hinzugefügt um die es [attachment=5708] geht
Es sind die Daten  aus D3 - N3

Danke
Grüße
aus dem schönen Bayern

Freddy

Excel 2013 Win8
Antworten Top
#5
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:
Grüße
aus dem schönen Bayern

Freddy

Excel 2013 Win8
Antworten Top
#6
Hallo Freddy,
Schön, das du es hinbekommen hast. Bin derzeit etwas gehandycapt, daher noch keine Antwort von mir...
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#7
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:
Grüße
aus dem schönen Bayern

Freddy

Excel 2013 Win8
Antworten Top
#8
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.
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#9
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
Grüße
aus dem schönen Bayern

Freddy

Excel 2013 Win8
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste