Hallo,
sorrx ... die Variablen sind als Modul-Var. deklariert, das With kam weiter oben im Code, da ich nicht den kompletten Code posten wollte.
Das mit der Zelle möchte ich jetzt nicht mehr umbauen ... würde ich dann aber sicher beim nächsten Mal beherzigen ;-)
Hier der (fast) komplette Code (ohne Sub_Finalrunde):
Option Explicit
Option Base 1
Dim AnzSpiele As Integer 'je Spieltag, nur für Gruppenspiele
Dim Spieltag As Integer
Dim AnzTN As Integer 'Anzahl Teilnehmer
Dim Runde As String
Dim wksAktuell As Worksheet
Dim str As String ' um Leerzeichen bereinigte Zeichenfolge (Erg./Tip)
Dim z As Integer 'Zeilenzähler
Dim s As Integer 'Spaltenzähler
Dim Zelle As Range
Dim Bereich As Range
Dim Bereich2 As Range
Dim rngName As Range ' Bereich der Namen der TN im Blatt Gesamtauswertung
Dim Ergebnis As String
Dim Tipp As String
Dim Punkte As Integer
Dim Geld As Single 'zu verteilendes Geld je Spieltag
Dim Geld1 As Single ' Gewinn Platz 1
Dim Geld2 As Single
Dim Geld3 As Single
Dim Anteil As Single
Dim Anteil1 As Single ' Gewinn Platz 1
Dim Anteil2 As Single
Dim Anteil3 As Single
Dim WertE As Integer
Dim WertT As Integer
Dim Tendenz As Integer
Dim i As Integer
Dim Punkte1 As Integer
Dim Punkte2 As Integer
Dim Punkte3 As Integer
Dim Platz As Integer
Dim AnzP1 As Integer
Dim AnzP2 As Integer
Dim AnzP3 As Integer
Dim rngNameFinden As Range
Dim col As Integer
Dim Zeile As Integer
Dim Name As String
Dim arrNameP1()
Dim arrNameP2()
Dim arrNameP3()
Dim arrPunkte(1 To 20, 1 To 2)
Sub Auswerten_Spieltag()
GlobalVars_fuellen
Select Case Spieltag
Case Is = 1, 2, 3
Vorrunde
Case Is > 3
'Finalrunde
End Select
End Sub
Sub Vorrunde()
' anhand des Spieltags 1,2 od. 3 das aktuelles Worksheet und Bereiche definieren
Select Case Spieltag
Case Is = 1
Set wksAktuell = tblSpieltag1
With wksAktuell
Set Bereich = .Range(.Cells(4, 4), .Cells(3 + AnzSpiele, 4 + AnzTN))
Set Bereich2 = tblGesamt.Range("C2:C" & AnzTN + 1)
End With
Case Is = 2
Set wksAktuell = tblSpieltag2
With wksAktuell
Set Bereich = .Range(.Cells(4, 4), .Cells(3 + AnzSpiele, 4 + AnzTN))
Set Bereich2 = tblGesamt.Range("D2:D" & AnzTN + 1)
End With
Case Is = 3
Set wksAktuell = tblSpieltag3
With wksAktuell
Set Bereich = wksAktuell.Range(.Cells(4, 4), .Cells(3 + AnzSpiele, 4 + AnzTN))
Set Bereich2 = tblGesamt.Range("E2:E" & AnzTN + 1)
End With
End Select
' Tipps prüfen/bereinigen sowie Bereich Punkte/Platz auf *blank setzen
For Each Zelle In Bereich
str = WorksheetFunction.Substitute(Zelle, " ", "") 'evtl. enthaltene Leerzeichen
Zelle = str
'keine 2-stelligen Ergebnisse
If Len(Zelle) > 3 Then
wksAktuell.Activate
Zelle.Select
MsgBox "Keine 2-stelligen Ergebnisse tippen; bitte Tip ändern!"
Exit Sub
End If
If Not Zelle = vbNullString Then
If Right(Zelle, 1) > "9" Or Right(Zelle, 1) z.B. §,!,Buchstaben, ...
Exit Sub
End If
If Left(Zelle, 1) > "9" Or Left(Zelle, 1) 2 And Zelle vbNullString Then
wksAktuell.Activate
Zelle.Select
MsgBox "Falscher Ergebnistrenner! Bitte durch Doppelpunkt ersetzen!"
Exit Sub
End If
Next
Bereich.Interior.ColorIndex = xlNone
With wksAktuell
.Range(.Cells(5 + AnzSpiele, 5), .Cells(6 + AnzSpiele, AnzTN + 4)).ClearContents
End With
Application.ScreenUpdating = False
If Not IsEmpty(tblGesamt.Cells(2, Spieltag + 2)) Then
Aktuellen_Spieltag_zurücksetzen
End If
' Analyse Tipps, Punkte-Addition und ggf. Zelle formatieren
With wksAktuell
For s = 5 To AnzTN + 4
Name = .Cells(3, s)
Punkte = 0
For z = 4 To AnzSpiele + 3
Ergebnis = .Cells(z, 4)
If Ergebnis = vbNullString Then
GoTo Ende_Schleifendurchlauf ' -> nächstes z
Else
Tipp = .Cells(z, s)
If Tipp = vbNullString Then
GoTo Ende_Schleifendurchlauf ' -> nächstes z
Else
WertE = Mid(Ergebnis, 1, 1) - Mid(Ergebnis, 3, 1)
WertT = Mid(Tipp, 1, 1) - Mid(Tipp, 3, 1)
End If
End If
If Ergebnis = Tipp Then
.Cells(z, s).Interior.ColorIndex = 6
Punkte = Punkte + 3
Else:
If WertE = WertT And WertE 0 Then
.Cells(z, s).Interior.ColorIndex = 4
Punkte = Punkte + 2
Else
If (WertE > 0 And WertT > 0) Or (WertE nächstes Spiel
.Cells(5 + AnzSpiele, s) = Punkte ' Punktzahl des TN eintragen
' Die Punktzahl wird direkt ins Blatt Gesamtauswertung übertragen
Set rngName = tblGesamt.Range("A2:A" & AnzTN + 1).Find(Name, LookAt:=xlWhole)
Zeile = rngName.Row
tblGesamt.Cells(Zeile, 2 + Spieltag) = Punkte
' Ermittlung der drei höchsten Punktzahlen, speichern der dazugehörigen Namen im _
entspr. Array
Select Case Punkte
Case Is > Punkte1
Punkte3 = Punkte2
AnzP3 = AnzP2
arrNameP3 = arrNameP2
Punkte2 = Punkte1
AnzP2 = AnzP1
arrNameP2 = arrNameP1
Punkte1 = Punkte
AnzP1 = 1
ReDim arrNameP1(AnzP1)
arrNameP1(AnzP1) = Name
Case Is = Punkte1
AnzP1 = AnzP1 + 1
ReDim Preserve arrNameP1(AnzP1)
arrNameP1(AnzP1) = Name
Case Is > Punkte2
Punkte3 = Punkte2
AnzP3 = AnzP2
arrNameP3 = arrNameP2
Punkte2 = Punkte
AnzP2 = 1
ReDim arrNameP2(AnzP2)
arrNameP2(AnzP2) = Name
Case Is = Punkte2
AnzP2 = AnzP2 + 1
ReDim Preserve arrNameP2(AnzP2)
arrNameP2(AnzP2) = Name
Case Is > Punkte3
Punkte3 = Punkte
AnzP3 = 1
ReDim arrNameP3(AnzP3)
arrNameP3(AnzP3) = Name
Case Is = Punkte3
AnzP3 = AnzP3 + 1
ReDim Preserve arrNameP3(AnzP3)
arrNameP3(AnzP3) = Name
End Select
Next s ' -> nächster Name Teilenhmer
End With
' Ermittlung Gewinn
Select Case AnzP1
Case Is > 2
Geld1 = (Anteil1 + Anteil2 + Anteil3) / AnzP1
Case Is = 2
Geld1 = (Anteil1 + Anteil2) / AnzP1
Geld2 = 0
Geld3 = Anteil3 / AnzP3
Case Is = 1
Geld1 = Anteil1 / AnzP1
Select Case AnzP2
Case Is = 1
Geld2 = Anteil2 / AnzP2
Geld3 = Anteil3 / AnzP3
Case Is > 1
Geld2 = (Anteil2 + Anteil3) / AnzP2
Geld3 = 0
End Select
End Select
' Sichern Gewinn-Spalte (nach Gewinn_sav)
With tblGesamt
.Range("K2:K" & AnzTN + 1).Copy
.Range("O2:O" & AnzTN + 1).PasteSpecial xlPasteAll
End With
' Hier wird für die erreichte Punktzahl die entspr. Platzierung ermittelt
For i = 1 To UBound(arrNameP1)
With wksAktuell
Set rngNameFinden = .Range(.Cells(3, 5), .Cells(3, 4 + AnzTN)).Find(arrNameP1(i))
col = rngNameFinden.Column
.Cells(6 + AnzSpiele, col) = 1
Name = arrNameP1(i)
Platz = 1
End With
Verarbeiten_Gesamtauswertung Name, Platz ' -> formatiert das Ergebnis in _
Gesamtauswertung
Next i
Select Case UBound(arrNameP1)
Case Is = 1 'nur ein Platz 1 -> daher gibt es auch Platz 2 und evtl. auch Platz 3
Select Case UBound(arrNameP2)
Case Is = 1 'es gibt noch 3. Plätze
With wksAktuell
Set rngNameFinden = .Range(.Cells(3, 5), .Cells(3, 4 + AnzTN)).Find( _
arrNameP2(1))
col = rngNameFinden.Column
.Cells(6 + AnzSpiele, col) = 2
Name = arrNameP2(1)
Platz = 2
Verarbeiten_Gesamtauswertung Name, Platz
End With
For i = 1 To UBound(arrNameP3)
With wksAktuell
Set rngNameFinden = .Range(.Cells(3, 5), .Cells(3, 4 + AnzTN)).Find( _
arrNameP3(i))
col = rngNameFinden.Column
.Cells(6 + AnzSpiele, col) = 3
Name = arrNameP3(i)
Platz = 3
Verarbeiten_Gesamtauswertung Name, Platz
End With
Next i
Case Is >= 2 'es gibt keine 3. Plätze mehr
For i = 1 To UBound(arrNameP2)
With wksAktuell
Set rngNameFinden = .Range(.Cells(3, 5), .Cells(3, 4 + AnzTN)).Find( _
arrNameP2(i))
col = rngNameFinden.Column
.Cells(6 + AnzSpiele, col) = 2
Name = arrNameP2(i)
Platz = 2
Verarbeiten_Gesamtauswertung Name, Platz
End With
Next i
End Select
Case Is = 2 ' zwei erste Plätze -> es gibt nur noch Platz 3, allerdings aus dem Array für _
Platz 2!!
For i = 1 To UBound(arrNameP2)
With wksAktuell
Set rngNameFinden = .Range(.Cells(3, 5), .Cells(3, 4 + AnzTN)).Find(arrNameP2(i) _
)
col = rngNameFinden.Column
.Cells(6 + AnzSpiele, col) = 3
Name = arrNameP2(i)
Platz = 3
Verarbeiten_Gesamtauswertung Name, Platz
End With
Next i
Case Is > 2 ' es werden keine weiteren Plätze mehr vergeben
End Select
' Gesamtauswertung neu sortieren
With tblGesamt
.Range(.Cells(2, 1), .Cells(AnzTN + 1, 13)).Sort _
Key1:=.Range("B1"), Order1:=xlDescending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Application.ScreenUpdating = True
Range("A1").Select
End Sub
' In dieser Sub-Routine wird die erreichte Punktzahl formatiert und die Gewinn-Spalte _
aktualisier
Sub Verarbeiten_Gesamtauswertung(Name As String, Platz As Integer)
With tblGesamt
Set rngName = .Range("A2:A" & AnzTN + 1).Find(Name, LookAt:=xlWhole)
Zeile = rngName.Row
Select Case Platz
Case Is = 1
.Cells(Zeile, 2 + Spieltag).Interior.ColorIndex = 6
.Cells(Zeile, 11) = .Cells(Zeile, 11) + Geld1
Case Is = 2
.Cells(Zeile, 2 + Spieltag).Interior.ColorIndex = 3
.Cells(Zeile, 11) = .Cells(Zeile, 11) + Geld2
Case Is = 3
.Cells(Zeile, 2 + Spieltag).Interior.ColorIndex = 8
.Cells(Zeile, 11) = .Cells(Zeile, 11) + Geld3
End Select
End With
End Sub
' Dieser Sub-Routine wird aufgerufen, falls ein Spieltag bereits mind. 1x ausgewertet wurde
Sub Aktuellen_Spieltag_zurücksetzen()
With tblGesamt
.Range("O2:O" & AnzTN + 1).Copy
.Range("K2:K" & AnzTN + 1).PasteSpecial xlPasteAll
End With
Bereich2.ClearContents ' Bereich2 sind die Spieltagpunkte
Bereich2.ClearFormats
End Sub
Sub Gesamtuswertung_komplett_zurücksetzen() ' alle Spieltage!
GlobalVars_fuellen
With tblGesamt.Range(Cells(2, 3), Cells(AnzTN + 1, 8))
.ClearContents
.ClearFormats
End With
For Each Zelle In tblGesamt.Range("O2:O" & AnzTN + 1)
Zelle = 0
Next
For Each Zelle In tblGesamt.Range("K2:K" & AnzTN + 1)
Zelle = 0
Next
End Sub
Sub GlobalVars_fuellen() ' variablen aus Blatt PARM
With tblParm
AnzSpiele = .Range("B2").Value / 2 'Anzahl der Mannschaften / 2
AnzTN = .Range("B3").Value
Spieltag = .Range("B4").Value
Runde = .Range("B5").Value
Anteil = .Cells(7, 3)
Anteil1 = Application.WorksheetFunction.Round(.Cells(10, 3), 2)
Anteil2 = Application.WorksheetFunction.Round(.Cells(11, 3), 2)
Anteil3 = Application.WorksheetFunction.Round(.Cells(12, 3), 2)
End With
End Sub
Sub VariablenZurücksetzen()
End
End Sub