AW: Rangliste erstellen
06.11.2015 20:53:32
Sepp
Hallo Jürgen,
hast recht und ich habe den Fehler gefunden.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Const cstrPassword As String = "geheim" 'Passwort für Blattschutz
Private Sub aktualisieren()
Dim objSh As Worksheet, rng As Range
Dim lngR As Long, lngC As Long, lngNext As Long, varRet As Variant
Dim bMatch As Boolean
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
lngNext = Application.Max(8, Cells(Rows.Count, 2).End(xlUp).Row)
Me.Unprotect cstrPassword
For Each objSh In ThisWorkbook.Worksheets
If objSh.Name Like "*. Turnier" Then
varRet = Application.Match(objSh.Name, Me.Rows(8), 0)
If IsNumeric(varRet) Then
lngC = varRet
With objSh
For lngR = 2 To Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row)
If .Cells(lngR, 2) <> "" Then
Set rng = Me.Columns(2).Find(What:=.Cells(lngR, 2), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rng Is Nothing Then
bMatch = True
If rng.Offset(0, 1) = .Cells(lngR, 3) Then
Cells(rng.Row, lngC) = .Cells(lngR, 4).Value
Else
bMatch = False
End If
Else
bMatch = False
End If
If Not bMatch Then
lngNext = lngNext + 1
Cells(lngNext, 2) = .Cells(lngR, 2)
Cells(lngNext, 3) = .Cells(lngR, 3)
Cells(lngNext, lngC) = .Cells(lngR, 4)
End If
End If
Next
End With
End If
End If
Next
Range("K6") = Date & Chr(10) & Time
Range("A9:A" & lngNext).FormulaR1C1 = "=RANK(RC[10],R9C11:R61C11)"
Range("K9:K" & lngNext).FormulaR1C1 = "=SUM(RC[-7]:RC[-2])"
Range("N9:S" & lngNext).FormulaR1C1 = "=IF(RC[-10]<>0,LARGE(RC4:RC9,COLUMN(R1C[-13])),0)"
On Error Resume Next
Set rng = Nothing
Set rng = Range(Cells(9, 4), Cells(lngNext, lngC)).SpecialCells(xlCellTypeBlanks)
If Not rng Is Nothing Then rng.Value = 0
On Error GoTo 0
Range("A8:K" & lngNext).Sort Key1:=Range("K8"), Order1:=xlDescending, Header:=xlYes
Me.Cells.Locked = True
Me.Protect cstrPassword
ErrorHandler:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'aktualisieren'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - aktualisieren"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.StatusBar = False
End With
Set rng = Nothing
End Sub
Private Sub reset()
If MsgBox("Wirklich alle Daten löschen?", vbQuestion + vbYesNo + vbDefaultButton2) = vbYes Then
Me.Unprotect cstrPassword
Range("A9:K" & Rows.Count) = ""
Range("N9:S" & Rows.Count) = ""
Range("K6") = ""
Me.Cells.Locked = True
Me.Protect cstrPassword
End If
End Sub
Gruß Sepp