Udregning af timer

Prøv at kigge på denne eksperten artikel om beregninger med dato og tid i Excel.
http://www.eksperten.dk/artikler/681

Du er velkommen til at sende planen til: pb@supertekst-it.dk

Resultatet blev følgende:

Rem Model 3 - 13-03-2008
Rem ====================
Const UgeStartRæk = 3
Const UgeDagStartKol = 2

Dim flag As Boolean, tid1, tid9, åbnRæk, lukRæk
Private Sub CommandButton1_Click()          'Nulstil vagter = Fri
Dim vagt
    flag = True
   
    For Each vagt In Range("A3:N20")
        If vagt.Font.Size = 14 And IsNumeric(vagt) = False Then
            vagt.Value = "Fri"
        End If
    Next
   
Rem Slet totaler - Kolonne 0 & P (Medarb.Uge-tim | ÅbnLuk-tim)
    Range("O3:P20").ClearContents
   
    flag = False
End Sub
Private Sub worksheet_activate()
    flag = False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)    'Aktiveres ved ændringer i arket
    If Target.Font.Size = 14 And IsNumeric(Target) = False And flag = False Then
        flag = True
        beregnTimer
        flag = False
    End If
End Sub
Sub beregnTimer()
Dim vagt, vagtTimer, medArbejder, dag, uge
Rem Slet totaler - Kolonne 0 & P (Medarb.Uge-tim | ÅbnLuk-tim)
    Range("O3:P20").ClearContents

    ræk = UgeStartRæk
   
    For uge = 1 To 4
        kol = UgeDagStartKol
       
        For dag = 1 To 7
Rem nulstil tidligste & seneste tid
            tid1 = 0
            tid9 = 0
           
            For medArbejder = 1 To 3
                vagt = Cells(ræk, kol)
                If vagt <> "" Then
                    vagtTimer = beregnVagtTimer(vagt, ræk, kol)
                    Cells(ræk, 15) = Cells(ræk, 15) + vagtTimer
                End If
               
                ræk = ræk + 1
            Next medArbejder
           
Rem Beregn tillæg for åbne/lukketid á 0,5 time for dagen
            If tid1 > 0 And tid9 > 0 Then
                Cells(åbnRæk, 16) = Cells(åbnRæk, 16) + 0.5
                Cells(lukRæk, 16) = Cells(lukRæk, 16) + 0.5
            End If
           
            ræk = UgeStartRæk + ((uge - 1) * 5)
            kol = kol + 2
        Next dag
       
        ræk = UgeStartRæk + (uge * 5)
    Next uge
End Sub
Private Function beregnVagtTimer(vagt, ræk, kol)
Dim fra, til, nFra, nTil
    If LCase(vagt) = "fri" Then
        beregnVagtTimer = 0
    Else
        fra = Left(vagt, 2)
        til = Mid(vagt, 4, 2)
       
        If IsNumeric(fra) = True And IsNumeric(til) = True Then
            nFra = Val(fra)
            nTil = Val(til)
           
            If nTil < nFra Then
                nTil = nTil + 24
            End If
           
Rem beregn tidligste & seneste tid
            If tid1 = 0 Then
                tid1 = nFra
                åbnRæk = ræk
            Else
                If nFra < tid1 Then
                    tid1 = nFra
                    åbnRæk = ræk
                End If
            End If
           
            If tid9 = 0 Then
                tid9 = nTil
                lukRæk = ræk
            Else
                If nTil > tid9 Then
                    tid9 = nTil
                    lukRæk = ræk
                End If
            End If
         
            beregnVagtTimer = nTil - nFra
        Else
            MsgBox ("Tidsperiode(2) ej numerisk: " + vagt)
            beregnVagtTimer = 0
        End If
    End If
End Function

takker mange gange for hjælpen

Selv tak..