Code- Beispiel und Datei als *.xls für Erich
08.08.2009 10:50:13
Tino
Hallo,
dafür musst Du erst mal alle Verbundenen Zellen raus machen.
Danach teste mal unten dieses Makro, einzigstes was mir noch nicht gefällt ist die Formatierung die beim Sortieren der Blöcke verrutscht.
Option Explicit
Sub SortBereiche()
Dim LCount As Long, LRow As Long, A As Long
Dim Bereich As Range
Dim iCalc As Integer
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
LCount = Application.WorksheetFunction.CountIf(Columns(1), "Name")
For A = 1 To LCount
If Bereich Is Nothing Then
Set Bereich = Cells.Find("Name", , xlValues, xlPart, xlByRows, xlNext, False, False, False)
Set Bereich = Bereich.Offset(1, 0)
LRow = Application.Match("Gesamt", Range(Bereich, Cells(Rows.Count, 1)), 0) - 2
Range(Bereich, Cells(LRow + Bereich.Row, 9)).Sort Bereich.Offset(0, 8), xlAscending, , , , , , xlNo
Else
Set Bereich = Cells.FindNext(Bereich)
Set Bereich = Bereich.Offset(1, 0)
LRow = Application.Match("Gesamt", Range(Bereich, Cells(Rows.Count, 1)), 0) - 2
Range(Bereich, Cells(LRow + Bereich.Row, 9)).Sort Bereich.Offset(0, 8), xlAscending, , , , , , xlNo
End If
Next A
With Sheets("Spieltag").UsedRange
With .Columns(.Columns.Count).Offset(0, 1)
.FormulaR1C1 = _
"=IF(OR(R[-1]C1=""Ergebnis"",RC1=""Schnitt"",R[-1]C1=""Schnitt""),R[-1]C,INDEX(RC1:R10000C9,MATCH(""Ergebnis"",RC1:R10000C1,0),9))"
.Offset(0, 1).FormulaR1C1 = "=ROW()"
Sheets("Spieltag").UsedRange.Sort .Cells(1, 1), xlAscending, .Cells(1, 1).Offset(0, 1), , xlAscending, , , xlNo
.Cells(1, 1).Offset(0, 1).EntireColumn.Delete
.EntireColumn.Delete
End With
End With
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic ' iCalc
End With
End Sub
Hier noch die Datei als xls, falls jemand anderes sich noch versuchen möchte.
https://www.herber.de/bbs/user/63699.xls
Gruß Tino