Thema
Fußballergebnisse eingeben und Tabelle sortieren
Gruppe
Change
Problem
Im Bereich B2:E5 werden Spielergebnisse eingegeben. Punkte und Tore werden automatisch errechnet und es wird nach Tabellenplatz sortiert.
ClassModule: Tabelle1 Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("B2:E5")) Is Nothing Then Exit Sub On Error GoTo 0 If Cells(Target.Row, 1).Value = Cells(1, Target.Column).Value Then Application.EnableEvents = False Beep MsgBox "Hier sind keine Eingaben erlaubt!" Target.ClearContents Application.EnableEvents = True Exit Sub End If If InStr(Target.Value, ":") = False Then Application.EnableEvents = False Beep MsgBox "Ungültige Eingabe!" Target.ClearContents Application.EnableEvents = True Exit Sub End If Call Sortieren ERRORHANDLER: Application.EnableEvents = True End Sub StandardModule: Modul1 Function Points(rng As Range) As Integer Dim oCell As Range Dim iPoints As Integer, iAct As Integer Dim sTxt As String For Each oCell In rng.Cells If Not IsEmpty(oCell) Then sTxt = oCell.Value iAct = Left(sTxt, InStr(sTxt, ":") - 1) - _ Right(sTxt, Len(sTxt) - InStr(sTxt, ":")) Select Case iAct Case Is > 0 iPoints = iPoints + 3 Case Is = 0 iPoints = iPoints + 1 End Select End If Next oCell Points = iPoints End Function Function Goals(rng As Range) As Integer Dim oCell As Range Dim iGoals As Integer, iAct As Integer Dim sTxt As String For Each oCell In rng.Cells If Not IsEmpty(oCell) Then sTxt = oCell.Value iAct = Left(sTxt, InStr(sTxt, ":") - 1) - _ Right(sTxt, Len(sTxt) - InStr(sTxt, ":")) iGoals = iGoals + iAct End If Next oCell Goals = iGoals End Function Function GoalsCount(rng As Range) As Integer Dim oCell As Range Dim iGoals As Integer, iAct As Integer Dim sTxt As String For Each oCell In rng.Cells If Not IsEmpty(oCell) Then sTxt = oCell.Value iAct = Left(sTxt, InStr(sTxt, ":") - 1) iGoals = iGoals + iAct End If Next oCell GoalsCount = iGoals End Function Sub Sortieren() Range("B1").CurrentRegion.Sort _ key1:=Range("F2"), order1:=xlDescending, _ key2:=Range("G2"), order2:=xlDescending, _ key3:=Range("H2"), order3:=xlDescending End Sub Sub Schuetzen() ActiveSheet.Protect userinterfaceonly:=True End Sub