Beregning af stoptid, driftstid m.m.

Sub Calculate()
Dim bStart As Boolean         'Flag for start
Dim bStop As Boolean          'Flag for stop
Dim rCell As Range            'Range variabel
Dim rTable As Range           'Tabellen med logdata
Dim arInput()                 'Arrayet med logdata
Dim lCount As Long            'Tæller
Dim lRow As Long              'Tæller
Dim lRow2 As Long             'Tæller
Dim lDualStart As Long        'Tæller starter uden stop
Dim lDualStop As Long         'Tæller stop uden start
Dim lLastRow As Long          'Antal rækker i arrayet/tabellen
Dim lTimeDiff As Long         'Tidsforskel mellem stop/start
Dim lStarts As Long           'Antal starter
Dim lStops As Long            'Antal stop
Dim lTotaltime As Long        'Tid mellem første og sidste logning
Dim dStopTime As Double       'Total stoptid
Dim colMotor As New Collection 'Collection til motornavne

On Error GoTo ErrorHandle

Worksheets(1).Activate

'Tabellens første række
Set rTable = Range("A2", Range("A2").End(xlToRight))

If Len(Range("A3").Value) = 0 Then
   MsgBox "Tabellen har kun én række."
   GoTo BeforeExit
End If

'Udvid rTable
Set rTable = Range(rTable, rTable.End(xlDown))

'Kopiér tabellen til arrayet. Det gør vi, fordi
'det er hurtigere at operere på et array.
'Arrayet får automatisk de samme dimensioner
'som tabellen.
arInput = rTable.Value

'Første motornavn
Set rTable = Range("G2")

If Len(rTable.Value) = 0 Then
   MsgBox "Celle G2 og ned skal indeholde mindst 1 motornavn."
   GoTo BeforeExit
End If

'Hvis der er mere end 1 motor,udvider vi rTable.
If Len(rTable.Offset(1, 0).Value) > 0 Then
   Set rTable = Range(rTable, rTable.End(xlDown))
End If

'For at sikre unikke navne, putter vi dem i en
'collection. Prøver man at tilføje en allerede
'eksisterende nøgle til en collection, udløser
'det en fejl, og derfor skriver vi:
'On Error Resume Next
'Det med at undgå dubletter er ikke strengt
'nødvendigt, og man kan sagtens undlade det.
'Det er blot med for eksemplets skyld.
'Hvis man dropper collection'en, kan man
'i stedet gennemløbe ranget med motornavne
'i den ydre løkke.
On Error Resume Next

For Each rCell In rTable
   colMotor.Add rCell.Value
Next

On Error GoTo ErrorHandle

'For nemheds skyld gemmer vi antallet af
'rækker i en variabel.
lLastRow = UBound(arInput)

'Nu beregner vi hele periodens længde, dvs. antal
'sekunder fra første til sidste række.
lTotaltime = DateDiff("s", arInput(1, 2), arInput(lLastRow, 2))

'Nu starter vi den ydre løkke, som gennemløber vores
'collection med motornavne. For hver motor gennemløbes
'arrayet med endnu en løkke. Den ældste logning er i 1.
'række, så vi gennemløber fra top til bund.
With colMotor
   'Gennemløb motor-collection
   For lCount = 1 To .Count
      lStarts = 0
      lStops = 0
      dStopTime = 0
      lDualStop = 0
      lDualStart = 0
      
      'Indre løkke som gennemløber rækkerne
      For lRow = 1 To lLastRow
         'Hvis motoren i første kolonne matcher motoren,
         'vi søger på.
         If arInput(lRow, 1) = .Item(lCount) Then
            'Hvis den startes, før vi har en stop-logning,
            'må den have været stoppet indtil nu, og stoptiden
            'fra 1. række til nu beregnes.
            If arInput(lRow, 3) = "START" And lStops = 0 Then
               bStart = True
               lStops = 1
               lStarts = 1
               'Hvis det ikke er 1. række, beregnes
               'stoptiden fra 1. række
               If lRow > 1 Then
                  lTimeDiff = DateDiff("s", arInput(lRow, 2), arInput(1, 2))
                  dStopTime = lTimeDiff
               End If
            End If
            'Hvis bStart er TRUE, og der er en ny start,
            'er der et stop, som ikke er blevet logget.
            'Det gør beregningen af stoptid m.m. upålidelig,
            'og for at kunne gøre opmærksom på det,
            'lægges der 1 til tælleren lDualStart.
            If arInput(lRow, 3) = "START" And bStart Then
               lDualStart = lDualStart + 1
               lStarts = lStarts + 1
            End If
            'Hvis der er stop på motoren
            If arInput(lRow, 3) = "STOP" Then
               bStop = True   'Sæt flag
               bStart = False 'Sæt flag
               'Opdater antal stop
               lStops = lStops + 1
               
               'Nu startes en indre løkke fremad for at finde
               'næste start
               For lRow2 = lRow + 1 To lLastRow
                  'Hvis motoren blev startet
                  If arInput(lRow2, 3) = "START" And _
                  arInput(lRow2, 1) = .Item(lCount) Then
                     'Vi beregner stoptiden
                     lTimeDiff = DateDiff("s", arInput(lRow, 2), _
                     arInput(lRow2, 2))
                     'Læg stoptiden til totalstoptiden
                     dStopTime = dStopTime + lTimeDiff
                     'lRow sættes = lRow2 for at springe frem
                     lRow = lRow2
                     bStop = False  'Flag
                     bStart = True  'Flag
                     'Opdatér antal starter
                     lStarts = lStarts + 1
                     'Forlad den indre løkke
                     Exit For
                  End If
                  'Hvis vi støder på endnu et STOP, har der været en start,
                  'som ikke er blevet logget, og vi lægger 1 til tælleren
                  'lDualStop.
                  If arInput(lRow2, 3) = "STOP" And _
                  arInput(lRow2, 1) = .Item(lCount) Then
                     lDualStop = lDualStop + 1
                  End If
                  'Hvis vi er kommet til sidste række uden at have fundet
                  'en start, var motoren stadig stoppet, da den sidste række
                  'blev logget, så vi lægger stoptiden fra sidste stop til
                  'sidste række til den totale stoptid.
                  If lRow2 = lLastRow And bStart = False And bStop Then
                     lTimeDiff = DateDiff("s", arInput(lRow, 2), _
                     arInput(lLastRow, 2))
                     dStopTime = dStopTime + lTimeDiff
                  End If
               Next
            
            End If
         End If
      Next
      
      'Kald WriteResult for at skrive en lille
      'tabel med resultaterne.
      WriteResult lStops, lStarts, dStopTime, _
      lTotaltime, lCount, .Item(lCount)
      If lDualStart > 0 Then
         MsgBox "Der er logget " & & lDualStart * 2 & " START uden stop." _
         & vbNewLine & _
         "De beregnede tider for " & .Item(lCount) & " er derfor usikre."
      End If
      If lDualStop > 0 Then
         MsgBox "Der er logget " & lDualStop * 2 & _
         "STOP uden start imellem." & vbNewLine & _
         "De beregnede tider for " & .Item(lCount) & " er derfor usikre."
      End If
   Next
End With

BeforeExit:
On Error Resume Next
Erase arInput
Set colMotor = Nothing
Set rTable = Nothing
Set rCell = Nothing

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure Calculate"
Resume BeforeExit
End Sub

Sub WriteResult(ByVal lStops As Long, ByVal lStarts As Long, _
ByVal dStopTime As Double, ByVal lTotaltime As Long, _
ByVal lCount As Long, ByVal sMotor As String)
'Skriver en tabel med stoptider osv. til Ark2.
'Sekunder omregnes til timer.

Dim arOutput(1 To 6, 1 To 3)  'Array til outputtabel
Dim rInsert As Range          'Range til tabel
Dim lStep As Long
Dim lRow As Long

On Error GoTo ErrorHandle

Application.ScreenUpdating = False

arOutput(1, 1) = "Stop " & sMotor
arOutput(2, 1) = "Starter " & sMotor
arOutput(3, 1) = "Total stoptid"
arOutput(4, 1) = "Total driftstid"
arOutput(5, 1) = "Gennemsnitlig tid mellem stop"
arOutput(6, 1) = "Hele periodens længde"

arOutput(1, 2) = lStops
arOutput(2, 2) = lStarts
arOutput(3, 2) = dStopTime / 3600
arOutput(4, 2) = (lTotaltime - dStopTime) / 3600
arOutput(5, 2) = lTotaltime / 3600 / lStops
arOutput(6, 2) = lTotaltime / 3600

arOutput(3, 3) = "Timer"
arOutput(4, 3) = "Timer"
arOutput(5, 3) = "Timer"
arOutput(6, 3) = "Timer"

Worksheets(2).Activate

'Hvis det er den første motor i vores collection,
'starter tabellen i celle A1. Ellers finder vi
'tabellens startcelle længere nede.
If lCount = 1 Then
   'Hvis det er den første motor, slettes gamle tabeller
   Cells.ClearContents
   Set rInsert = Range("A1")
Else
   For lStep = 1 To lCount
      lRow = lStep + 6
   Next
   Set rInsert = Range("A" & lRow)
End If

'Definér tabellens range
Set rInsert = Range(rInsert, rInsert.Offset(5, 2))

'Kopierer arrayet til ranget i ét hug
rInsert.Value = arOutput

BeforeExit:
On Error Resume Next
Erase arOutput
Set rInsert = Nothing
Application.ScreenUpdating = True

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure WriteResult"
Resume BeforeExit
End Sub