Makro:Liste von Dienstzeiten sauber umbauen

Aus XIMES

Was tut es?

Liest aus einer Datei in der viele Dienste mit Zeiten sind ein und wertet Zeiten als Zahl aus

   Dienst  Zeiten  Stunden
   AbteilungA 2005
   T    0800-2000   11,5
   L    0600-1800   11,5
   TN   0900-2100   11,5
   ...
   AbteilungB 2006
   T1    0800-2000   11,5
   L2    0600-1800   11,5
   TN2   0900-2100   11,5
   ...

und wandelt sie um in zB

   ABTEILUNG    JAHR   VON     BIS
   AbteilungA   2005   08:00   20:00
   AbteilungA   2005   06:00   18:00
   ....

Setzt voraus

• Umwandlungsrechner in Makro:IsTime und MakeTime

Makro

    Option Explicit
   ' Liest aus einer Datei in der viele Dienste mit Zeiten sind ein und wertet Zeiten aus
   ' Wenn Länge des Dienstes vorliegen kann zusätzlich geprüft werden
   ' Dienst  Zeiten  Stunden
   ' AbteilungA 2005
   ' T    0800-2000   11,5
   ' L    0600-1800   11,5
   ' TN   0900-2100   11,5
   ' ...
   ' AbteilungB 2006
   ' T1    0800-2000   11,5
   ' L2    0600-1800   11,5
   ' TN2   0900-2100   11,5
   ' ...
  'NICHT VERGESSEN
  ' Blatt mit Name Result anlegen
  ' Adressbezüge anpassen
  ' Prüfen das alle Blätter gleich von Zeilen anfangen
  ' Es werden die Daten und die Rohdaten und ein Prüfkommentar ausgegeben
  
  Sub GetData()
  Dim sh As Worksheet
  Dim werte As Range
  Dim result As Range
  Dim i, j As Integer
  Dim printline As Long
  Dim Jahr As Integer
  Dim Bereich As String
      
  Set result = Worksheets("Result").Cells
  result.ClearContents
  result(1, 1) = "Jahr"
  result(1, 2) = "Bereich"
  result(1, 3) = "Name"
  result(1, 4) = "Von"
  result(1, 5) = "Bis"
  result(1, 6) = "Länge" 'kann entfallen wenn Stunden
  result(1, 7) = "Von2"
  result(1, 8) = "Bis2"
  result(1, 9) = "Orig"
  result(1, 10) = "Check" '***Spalte für Prüfung
  
  
  printline = 2
  
          Set sh = ActiveWorkbook.ActiveSheet
          Set werte = sh.Cells
          '***ANPASSEN ZEILEN in denen Daten stehen
          For i = 2 To 400
              
              Select Case werte(i, 2)
              
              Case "", 0
                   If werte(i, 1) <> "" Then
                       Jahr = Val(Right(werte(i, 1), 4))
                       Bereich = Left(werte(i, 1), Len(werte(i, 1)) - 5)
                       If Jahr <> 2005 And Jahr <> 2006 Then Stop
                       If Bereich = "" Then Stop
                   End If
              Case Else
                  
                     printquick result, printline, Jahr, Bereich, werte(i, 2), werte(i, 1), werte(i, 3)
              End Select
           
          Next
  
  
  End Sub

 'Hilfsfunktion für Ausgabe inklusive Option
 Private Sub printquick(wohin As Range, line As Long, Jahr As Integer, Bereich As String, datum As Variant, Dienst As String, _
      Optional Checksum As Variant = -1, Optional bGeheNächsteZeile As Boolean = True)
 ' Bereich ... nur Text der Durchgegeben wird
 ' Jahr nur Wert der durchgegeben wird
 ' Dienst Nur Name der durchgegeben wird
 ' Datum so kommt Von-Bis Struktur
 ' Checksum ... optionnl genutzt, wenn bekannt ist wie lange Dienste sein sollte
 Dim wo As Integer
 Dim von, bis As Double
 Dim diff As Double
 
       wo = InStr(datum, "-")
       If Not IsNumeric(wo) Then wo = 4 Else wo = wo - 1
       If wo <= 0 Then wo = 4
       
 
     wohin(line, 1) = Bereich
     wohin(line, 2) = Jahr
     wohin(line, 3) = Dienst
     von = MakeTime(Left(datum, wo))
     bis = MakeTime(Right(datum, Len(datum) - wo - 1))
     wohin(line, 4) = von
     wohin(line, 5) = bis
     wohin(line, 6) = Checksum
     wohin(line, 7) = Left(datum, wo)
     wohin(line, 8) = Right(datum, wo)
     wohin(line, 9) = datum
     '
     If wohin(line, 4) = "" Or wohin(line, 5) = "" Then Stop
          
     If IsNumeric(Checksum) Then
       If Checksum >= 0 Then
           ' Diff in Stunden gerechnet
             If von > bis Then diff = 24 Else diff = 0
             diff = diff + bis * 24 - von * 24
             If (diff - Checksum) ^ 2 > 0.000001 Then
                     
                     'Prüfung auf Abweichung 0,5h Pause ist ok
                     '*** ANPASSEN
                     If ((diff - Checksum) - 0.5) ^ 2 < 0.00001 Then
                       wohin(line, 10) = "Pause"
                     Else
                      'HINWEIS: Hier Guter Breakpoint, um Sorgenkandidtaten zu finden
                       wohin(line, 10) = "uups"
                     End If
             End If
        End If
     Else
       'Es gab keine Zahl zu prüfen, aber es war was in der Zeile
       wohin(line, 10) = "ungeprüft"
     End If
      '

     If bGeheNächsteZeile Then line = line + 1
     '
 End Sub