HERBERS Excel-Forum - die Beispiele

Thema: Splittung der Arbeitszeit in Normal- und Überstunden

Home

Gruppe

DatumZeit

Problem

Arbeitszeit soll unter Berücksichtigung von Pause und Regelarbeitszeit in Normalarbeitszeit und Überstunden gesplittet werden.

Lösung
Darstellung nur anhand einer Beispielarbeitsmappe möglich.
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