Registriert seit: 14.04.2014
Version(en): Office 2013
14.06.2016, 13:50
(Dieser Beitrag wurde zuletzt bearbeitet: 14.06.2016, 13:51 von 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
Grüße
aus dem schönen Bayern
Freddy
Excel 2013 Win8
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
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)
Registriert seit: 14.04.2014
Version(en): Office 2013
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
Registriert seit: 14.04.2014
Version(en): Office 2013
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
Registriert seit: 14.04.2014
Version(en): Office 2013
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
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
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)
Registriert seit: 14.04.2014
Version(en): Office 2013
25.06.2016, 14:09
(Dieser Beitrag wurde zuletzt bearbeitet: 25.06.2016, 14:09 von freddy.
Bearbeitungsgrund: Hinzufügen
)
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
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
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)
Registriert seit: 14.04.2014
Version(en): Office 2013
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
|