Sub SortBereiche()
Dim LCount As Long, LRow As Long
Dim Bereich As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
LCount = Application.WorksheetFunction.CountIf(Columns(1), "Name")
For LCount = 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 LCount
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
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
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
LRow = Application.Match("Name", Columns(1), 0)
With Range(Cells(LRow, 10), Cells(Rows.Count, 1).End(xlUp).Offset(4, 9))
.FormulaR1C1 = _
"=IF(OR(R[-1]C1=""Ergebnis"",COUNTIF(R[-4]C1:RC1,""Schnitt"")>0),R[-1]C,INDEX(RC1:R10000C9,MATCH(""Ergebnis"",RC1:R10000C1,0),9))"
Range(Cells(LRow, 1), Cells(Rows.Count, 10).End(xlUp)).Sort Cells(LRow, 10), xlAscending, , , , , , xlNo
.Cells(1, 1).Offset(0, 1).EntireColumn.Delete
.EntireColumn.Delete
End With
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
End Sub
With Range(Cells(LRow, 10), Cells(Rows.Count, 1).End(xlUp).Offset(4, 9))
"=IF(OR(R[-1]C1=""Ergebnis"",COUNTIF(R[-4]C1:RC1,""Schnitt"")>0),R[-1]C,INDEX(RC1:R10000C9,MATCH(""Ergebnis"",RC1:R10000C1,0),9))
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
LRow = Application.Match("Name", Columns(1), 0)
With Range(Cells(LRow, 10), Cells(Rows.Count, 1).End(xlUp).Offset(5, 9))
.FormulaR1C1 = _
"=IF(OR(R[-1]C1=""Ergebnis"",COUNTIF(R[-5]C1:RC1,""Schnitt"")>0),R[-1]C,INDEX(RC1:R10000C9,MATCH(""Ergebnis"",RC1:R10000C1,0),9))"
Range(Cells(LRow, 1), Cells(Rows.Count, 10).End(xlUp)).Sort Cells(LRow, 10), xlAscending, , , , , , xlNo
.Cells(1, 1).Offset(0, 1).EntireColumn.Delete
.EntireColumn.Delete
End With
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
End Sub
Sub SortBereiche()
Dim LCount As Long, LRow As Long, A As Long
Dim Bereich As Range
Dim iCalc As Integer
Dim objTab As Worksheet
'hier den Tabellennamen und die Zelle anpassen wo die Tabelle drin steht
'im Beispiel hier ist es die Tabelle2 Zelle A1
Set objTab = Worksheets(Worksheets("Tabelle2").Range("A1").Text)
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
With objTab
LRow = Application.Match("Name", .Columns(1), 0)
With .Range(.Cells(LRow, 10), .Cells(.Rows.Count, 1).End(xlUp).Offset(5, 9))
.FormulaR1C1 = _
"=IF(OR(R[-1]C1=""Ergebnis"",COUNTIF(R[-5]C1:RC1,""Schnitt"")>0),R[-1]C,INDEX(RC1:R10000C9,MATCH(""Ergebnis"",RC1:R10000C1,0),9))"
objTab.Range(objTab.Cells(LRow, 1), objTab.Cells(objTab.Rows.Count, 10).End(xlUp)).Sort objTab.Cells(LRow, 10), xlAscending, , , , , , xlNo
.Cells(1, 1).Offset(0, 1).EntireColumn.Delete
.EntireColumn.Delete
End With
End With
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
End Sub