AW: Macro VBAProject (Personal.WLS)/Module/Modul1
04.11.2010 12:43:10
Rüdiger
Hallo Dieter,
hier das Korrektur-Macro:
Denke darn, ich vermute es!
Gruß Rüdiger
Public Function Korrektur(Rang As Range, Rang_bereich As Range, _
Ergebnisse As Range, Balldifferenz As Range) As Long
'Ermittlung der Rangkorrektur auf Basis der Spiele gegeneinander wenn 2 oder _
mehr Spieler gleiche Punktzahl und Satzgewinne.
Dim Zeile As Long, AnzMehrfach As Long, iIndex As Long, iRang As Long
Dim sErgebnis As String
Dim arrTemp(), arrHilf(), Zeile_Korrektur As Long
'On Error GoTo Fehler
'Häufigkeit des Ranges in der im Rangbereich (1. Auswertung)
AnzMehrfach = Application.WorksheetFunction.CountIf(Rang_bereich, Rang.Value)
ReDim arrTemp(1 To AnzMehrfach, 1 To 6)
ReDim arrHilf(1 To AnzMehrfach)
'Zeilennummern der Spieler mit identischem Rang einlesen in Spalte 1 des Arrays
For Zeile = 1 To Rang_bereich.Rows.Count
If Rang_bereich(Zeile, 1) = Rang.Value Then
iIndex = iIndex + 1
arrTemp(iIndex, 1) = Zeile
'Array-Zeile merken, in der der ggf. zu korrigierende Rang steht.
If Rang.Row = Rang_bereich(Zeile, 1).Row Then Zeile_Korrektur = iIndex
End If
Next
'Ergebnisse gegen ranggleiche Spieler einlesen und auswerten
For Zeile = 1 To AnzMehrfach
arrTemp(Zeile, 3) = 0 'Spalte in der Punkte gegen ranggleiche summiert werden
arrTemp(Zeile, 4) = 0 'Spalte in der Satzdifferenzen gegen ranggleiche summiert werden
arrTemp(Zeile, 5) = 0 'Spalte in der der Hilfswert für Auswertung der Ergebnisse _
gegeneinander eingetragen wird
arrTemp(Zeile, 6) = 0 'Spalte in der die Balldifferenzen gegen ranggleiche summiert werden
For iIndex = 1 To AnzMehrfach
If arrTemp(Zeile, 1) arrTemp(iIndex, 1) Then
'Ergebnis des Spiels einlesen
sErgebnis = Application.WorksheetFunction.Index(Ergebnisse, _
arrTemp(Zeile, 1), arrTemp(iIndex, 1))
'Punkte aus Ergebnis ermitteln - 1 Punkt wenn gewonnen
'Linke Ziffer des Ergebnisses prüfen
If Left(sErgebnis, 1) = "3" Then
arrTemp(Zeile, 3) = arrTemp(Zeile, 3) + 1
End If
'Gesamt-Satzdifferenz - Differenz linke minus rechte Ziffer aufsummieren
arrTemp(Zeile, 4) = arrTemp(Zeile, 4) _
+ Val(Left(sErgebnis, 1)) - Val(Right(sErgebnis, 1))
'Balldifferenz des Spiels einlesen
sErgebnis = Application.WorksheetFunction.Index(Balldifferenz, _
arrTemp(Zeile, 1), arrTemp(iIndex, 1))
'Balldifferenz aufsummieren
arrTemp(Zeile, 6) = arrTemp(Zeile, 6) + Val(sErgebnis)
End If
Next
'Hilfswert für Korrekturberechnung ermitteln und in Spalte 5 des Array eintragen
'Berücksichtigt werden in der Reihenfolge Punkte, Satzdifferenz und Balldifferenz aus _
den Spielen gegen die ranggleichen Spieler
arrTemp(Zeile, 5) = arrTemp(Zeile, 3) * 100000 + arrTemp(Zeile, 4) * 1000 _
+ arrTemp(Zeile, 6)
arrHilf(Zeile) = arrTemp(Zeile, 5) 'Array mit Hilfswerten für Korrekturberechnung
Next
'Array mit Hilfswerten sortieren
Call QuickSort(VA_array:=arrHilf)
'Rang-Korrekturwert nach Vergleich der Hilfswerte in Spalte 2 des Hauptarrays eintragen
iRang = 0
For Zeile = AnzMehrfach To 1 Step -1
If Zeile arrHilf(Zeile + 1) Then iRang = iRang + 1
End If
For iIndex = 1 To AnzMehrfach
If arrHilf(Zeile) = arrTemp(iIndex, 5) Then
arrTemp(iIndex, 2) = iRang
End If
Next
Next
'Korrekturwert dem Funktions-Ergebnis zuweisen
Korrektur = arrTemp(Zeile_Korrektur, 2)
Err.Clear
'Fehler:
'With Err
'Select Case .Number
'Case 0 'Alles ok
'Case Else
'MsgBox "Fehler-Nr.: " & .Number & vbNewLine & .Description
'End Select
'End With
End Function
Private Sub QuickSort(ByRef VA_array, Optional V_Low1, Optional V_high1)
'aus www.Herber.de Excel-Forum
On Error Resume Next
Dim V_Low2, V_high2, V_loop As Integer
Dim V_val1, V_val2 As Variant
If IsMissing(V_Low1) Then
V_Low1 = LBound(VA_array, 1)
End If
If IsMissing(V_high1) Then
V_high1 = UBound(VA_array, 1)
End If
V_Low2 = V_Low1
V_high2 = V_high1
V_val1 = VA_array((V_Low1 + V_high1) / 2)
While (V_Low2 V_val1 And _
V_high2 > V_Low1)
V_high2 = V_high2 - 1
Wend
If (V_Low2 V_Low1) Then Call _
QuickSort(VA_array, V_Low1, V_high2)
If (V_Low2