Warum läuft es in Ecxel 8.0 nicht?
Sub mannschaftswertung19012002()
Dim i As Integer, j As Integer, k As Integer, m As Integer
Application.ScreenUpdating = False
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
' Inhalt des Tabellenblattes löschen
Sheets("mannschaft").Select
Range("A2:O1000").Select
Selection.ClearContents
m = Application.InputBox("Wie viele Teilnehmer gehören zu einer Mannschaft ?", "Gleiche eingeben", 3, Type:=1)
If m <= 0 Then
Exit Sub
End If
'wird für ein anderes Makro benötigt
Range("X1").Value = m
'Kopieren Tabellenblat Zeitnahme und einfügen in Tabellenblatt Mannschaft
Sheets("Zeitnahme").Select
Range("A2:M1000").Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=-5
Sheets("mannschaft").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Dim x%
Selection.Sort Key1:=Range("K2"), _
Order1:=xlAscending, Key2:=Range("D2"), _
Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
i = 2
j = 2
Do While Cells(i, 11) <> ""
k = 1
Do While Cells(i, 11) = Cells(j, 11)
j = j + 1
k = k + 1
Loop
If k <> m Then
If k < m Then
Rows(i & ":" & j - 1).Delete Shift:=xlUp
Else
Rows(i + m & ":" & j - 1).Delete Shift:=xlUp
i = i + m
End If
j = i + 1
Else
i = i + m
j = i + 1
End If
Loop
Selection.Delete Shift:=xlUp
Range("N2").Select
For zi = 1 To m Step 1
formel = "=SUM(R[" & (1 - zi) & "]C[-10]:R[" & (m - zi) & "]C[-10])"
ActiveCell.FormulaR1C1 = formel
Range("N" & (2 + zi)).Select
Next
Range("N2:N" & (1 + m)).AutoFill Destination:=Range("N2:N1000"), Type:=xlFillDefault
Range("N2:N1000").Select
ActiveWindow.LargeScroll Down:=-25
Dim Letzte As Long
Dim A As Long
If [N1000] = "" Then
Letzte = [N1000].End(xlUp).Row
Else
Letzte = 1000
End If
On Error Resume Next
For A = 1 To Letzte
If Cells(A, 14) < CDate("0:0:1") Then Cells(A, 14).ClearContents
Next A
ActiveSheet.UsedRange.Select
zeilen = Selection.Rows.Count
For A = zeilen To 1 Step -1
If Cells(A, 11).Value < 1 Then
Rows(A).Select
Selection.Delete Shift:=xlUp
End If
Next
Range("A2").Select
Selection.Sort Key1:=Range("N2"), _
Order1:=xlAscending, Key2:=Range("K2"), _
Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
i = 1
For A = 2 To zeilen - m Step m
Cells(A, 15).Value = i
i = i + 1
Next
Application.ScreenUpdating = True
Range("O1").Select
End Sub
Vielen Dank für eure Hilfe!!
Tschüß
Rolf