Hallo,
Fußball ist ganz schön kompliziert.
teste mal, fange aber beim 1.Spieltag an.
Option Explicit
Sub Spieltagübersicht()
Dim Bereich As Range, tBereich As Range
Dim meAr, LRow, LCol
Dim i As Integer
Dim NeuTab As Worksheet
Dim sFormel As String
Dim A As Long, tempCol As Long
Dim sSpieltag As String
Dim B As Long
If InStr(Sheets("Gesamt").Range("A2").Text, "ok") = 0 Then Exit Sub
sSpieltag = Trim$(Replace(Sheets("Gesamt").Range("A2").Text, "ok", "")) & ". Spieltag"
If IsNumeric(Application.Match(sSpieltag, Sheets("Übersicht").Columns(1), 0)) Then
MsgBox "Speiltag ist schon in der Übersicht vorhanden!", vbInformation
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Sheets("Gesamt")
Set Bereich = .Range("A3:A20")
Redim meAr(305, 6)
For Each Bereich In Bereich
Set tBereich = .Range(Bereich.Offset(0, 2), Bereich.Offset(0, 55))
For A = 1 To 18
For B = 1 + B To tBereich.Cells.Count - 1
If tBereich(B) <> "" And tBereich(B) <> ":" Then
LCol = B + 2
B = B + 2
Exit For
End If
Next B
If IsNumeric(LCol) Then
tempCol = tempCol + LCol
Sheets("Übersicht").Range("B1").FormulaR1C1 = _
"=SUMPRODUCT((R[1]C:R[500]C=""" & Bereich & """)*(R[1]C[2]:R[500]C[2]=""" & .Cells(2, LCol) & """))"
If Sheets("Übersicht").Range("B1") = 0 Then
meAr(i, 0) = sSpieltag
meAr(i, 1) = Bereich
meAr(i, 2) = "gegen"
meAr(i, 3) = .Cells(2, LCol)
meAr(i, 4) = .Cells(tBereich.Row, LCol)
meAr(i, 5) = ":"
meAr(i, 6) = .Cells(tBereich.Row, LCol + 2)
i = i + 1
tempCol = tempCol + 1
If tempCol > 53 Then Exit For
End If
Sheets("Übersicht").Range("B1").Value = ""
If tempCol > 53 Then Exit For
Else
Exit For
End If
Next A
tempCol = 0
B = 0
Next Bereich
End With
Sheets("Übersicht").Range("B1").Value = ""
Set NeuTab = Sheets("Übersicht")
With NeuTab
LRow = Application.Match(meAr(0, 0), .Columns(1), 0)
If Not IsNumeric(LRow) Then
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
LRow = IIf(LRow = 3, 2, LRow)
End If
.Cells(LRow, 1).Resize(Ubound(meAr, 1) + 1, Ubound(meAr, 2) + 1) = meAr
.Cells(LRow, 1).EntireColumn.Font.Bold = True
.Cells(LRow, 1).EntireColumn.Font.ColorIndex = 23
.Range(.Cells(LRow, 1), .Cells(LRow, 7)).EntireColumn.AutoFit
.Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Offset(0, 7).FormulaR1C1 = _
"=--LEFT(RC1,FIND(""."",RC1)-1)"
'Sortieren
.Range("A2:H" & .Rows.Count).Sort .Range("H2"), xlAscending
.Columns(8).Value = ""
'Zwischenzeile einfügen
For LRow = .Cells(Rows.Count, 1).End(xlUp).Row - 1 To 2 Step -1
If .Cells(LRow, 1) <> .Cells(LRow + 1, 1) Then
.Cells(LRow + 1, 1).EntireRow.Insert
End If
Next LRow
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Daten wurden in die Übersicht aufgenommen!", vbInformation
End Sub
Gruß Tino