Gruppe
DatumZeit
Problem
Arbeitszeit soll unter Berücksichtigung von Pause und Regelarbeitszeit in Normalarbeitszeit und Überstunden gesplittet werden.
StandardModule: Modul1
Sub Main()
Dim rngTeams As Range, rngPairs As Range
Dim iRow As Integer, iCount As Integer
Application.ScreenUpdating = False
Range("C:E").ClearContents
iRow = Cells(Rows.Count, 1).End(xlUp).Row
Set rngTeams = Range(Cells(2, 1), Cells(iRow, 1))
iCount = rngTeams.Cells.Count
Call Paarungen(rngTeams, iCount)
Set rngPairs = Range("C1").CurrentRegion
Call PlanAnlegen(rngPairs, iCount)
Application.ScreenUpdating = True
End Sub
Sub Paarungen(rng As Range, iCount As Integer)
Dim iRow As Integer, iA As Integer, iB As Integer, iC As Integer, iD As Integer
Dim bln As Boolean
iRow = 1
For iA = 1 To iCount
For iB = iA To iCount
If iA <> iB Then
bln = Not bln
If bln Then
Cells(iRow, 3).Value = rng(iA)
Cells(iRow, 4).Value = rng(iB)
Else
Cells(iRow, 4).Value = rng(iA)
Cells(iRow, 3).Value = rng(iB)
End If
Cells(iRow, 5).Value = 0
iRow = iRow + 1
End If
Next iB
Next iA
End Sub
Sub PlanAnlegen(rng As Range, iCount As Integer)
Dim rngCellA As Range, rngCellB As Range, rngAct As Range
Dim iRow As Integer, iCounter As Integer, iAct As Integer
Dim bln As Boolean
Workbooks.Add 1
Range("A1").Value = "Spielplan"
For iRow = 3 To (iCount + 1) * (iCount + 1) / 2 Step (iCount / 2) + 2
iCounter = iCounter + 1
Cells(iRow, 1).Value = iCounter & ". Spieltag"
Range(Cells(iRow + 1, 1), Cells(iRow + (iCount - 1) / 2, 2)).Name = "Tag" & iCounter
Next iRow
For iCounter = 1 To iCount - 1
For Each rngAct In rng.Columns(1).Cells
If rngAct.Offset(0, 2).Value = 0 Then
Set rngCellA = Range("Tag" & iCounter).Find(rngAct.Value, LookIn:=xlValues, lookat:=xlWhole)
Set rngCellB = Range("Tag" & iCounter).Find(rngAct.Offset(0, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
If rngCellA Is Nothing And rngCellB Is Nothing Then
iAct = 1
Do Until IsEmpty(Range("Tag" & iCounter).Columns(1).Cells(iAct))
iAct = iAct + 1
Loop
Range("Tag" & iCounter).Cells(iAct, 1).Value = rngAct.Value
Range("Tag" & iCounter).Cells(iAct, 2).Value = rngAct.Offset(0, 1).Value
rngAct.Offset(0, 2).Value = 1
End If
End If
Next rngAct
Next iCounter
Columns.AutoFit
End Sub