Hallo Andre!
Hier nun das fast fertige Makro und es läuft!Public Sub mannschaftswertung19012002()
Dim lgRow As Long
Dim lgCount As Long
Dim l As Long
Dim Letzte As Long
Dim start As Variant
Dim p As Integer
Dim u As Integer
Dim i As Integer, j As Integer, k As Integer, t As Integer, s As Integer, h As Variant, r As Integer, b As Variant
Dim intCounter As Integer, LetzteZelle As Integer, Anfang As Integer
Application.ScreenUpdating = False
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
' Löschen
Sheets("mannschaft").Select
Range("A2:O1000").Select
Selection.ClearContents
' holt aus Tabellenblatt
Sheets("Zeitnahme").Select
Range("A2:M1000").Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=-5
' fügt ein
Sheets("mannschaft").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
' sortiert
Dim x%
Selection.Sort Key1:=Range("K2"), _
Order1:=xlAscending, Key2:=Range("D2"), _
Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
' löscht Zeilen wenn in
p = Cells(Rows.Count, 2).End(xlUp).Row
For u = p To 2 Step -1
If Cells(u, 11) = "" Then Rows(u & ":" & u).Delete Shift:=xlUp
Next
Application.ScreenUpdating = True
m = Application.InputBox("Wie viele Teilnehmer gehören zu einer Mannschaft ?", "Gleiche eingeben", 6, Type:=1)
If m <= 0 Then Exit Sub
'wichtig für Makro Urkundendruck
Range("X1").Value = m
' Kopieren
j = Cells(Rows.Count, 11).End(xlUp).Row
For i = 1 To 1000
A = Application.WorksheetFunction.CountIf(Range("k2:K" & j), i)
If A = 0 Then GoTo ende
Range("k:k").Select
Selection.Find(What:=i, After:=[k1], LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate
start = ActiveCell.Row
If A < m Then
loescheMannschaft start, start + A - 1
End If
If A > m Then
loescheMannschaft start + m, start + A - 1
End If
ende:
Next
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
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
' MsgBox (zeilen)
For A = zeilen To 1 Step -1
Next
Range("A2").Select
Selection.Sort Key1:=Range("N2"), _
Order1:=xlAscending, Key2:=Range("D2"), _
Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
h = Cells(Rows.Count, 2).End(xlUp).Row
For s = h To 2 Step -1
If Cells(s, 11) = "" Then Rows(s & ":" & s).Delete Shift:=xlUp
Next
LetzteZelle = Cells(Cells.Rows.Count, 11).End(xlUp).Row
Anfang = 2 'Alternativ Anfang = ActiveCell.Row
For intCounter = Anfang To LetzteZelle
If IsNumeric(Cells(intCounter - 1, 11)) Then
If Cells(intCounter, 11) <> Cells(intCounter - 1, 11) Then
Cells(intCounter, 11).Offset(0, 4) = _
Cells(intCounter, 11).Offset(-1, 4) + 1
Else
Cells(intCounter, 11).Offset(0, 4) = _
Cells(intCounter, 11).Offset(-1, 4)
End If
Else
Cells(intCounter, 11).Offset(0, 4) = 1
End If
Next intCounter
Application.ScreenUpdating = True
Range("A1").Select
End Sub
Private Sub loescheMannschaft(start, i)
Rows(start & ":" & i).Delete Shift:=xlUp
End Sub
Ne kleine Frage habe ich noch:
' zu Zeilen löschen
h = Cells(Rows.Count, 2).End(xlUp).Row
For s = h To 2 Step -1
If Cells(s, 11) = "" Then Rows(s & ":" & s).Delete Shift:=xlUp
Next
Wie du oben sehen kannst hole ich die Daten aus einem anderen Tabellenblatt. Wenn nun Spalte 11 Zellen stehen die zwar leer aussehen, aber nicht leer sind, werden Sie nicht gelöscht.
Ich lösche per Leertaste eine Zahl aus Spalte 11, diese wird dann nicht als leer erkannt. Erst ween ich rechte Maustaste Inhalte lösche arbeite wir die Zelle als leer erkannt.
Vielleicht hast du da noch mal eine Idee?
Vielen Dank!
Tschüß
Rolf