Gruppe
Ereignis
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