Microsoft Excel

Herbers Excel/VBA-Archiv

Ruhezeiten kontr.- Teil 2


Betrifft: Ruhezeiten kontr.- Teil 2
von: STeve
Geschrieben am: 20.12.2018 10:47:58

Hallo liebe Helfer!!! - speziell an Fennek.......Habe eine Bitte am 12.12.2018 23:11:15 unter dem Titel:

Ruhezeiten kontrollieren im Dienstplan......eingestellt.

Schnelle Hilfe erhalten durch Fennek am 13.12.2018 09:53:31

Leider kann ich den Beitrag nicht mehr erweitern/weitere Bitten/Fragen einstellen???......deshalb dieser neue Beitrag/Ansuchen zum gleichen Projekt.

http://www.herber.de/bbs/user/126060.xls

Fenneks- Code wurde - auch für mich verständlich ;-) - so adaptiert:

Sub F_en()  ' Version 1 - Herber - "Fennek" Dez18
 
 Dim rng As Range
 Dim C As Range
 Dim D As Range
 Dim Ez As Date 'Endzeit
 Dim Sz As Date 'Startzeit
 Dim dasDatumindersiebtenZeile As Date
 Dim Fr As Range
 Dim DatumdesFreitag As Date
 Dim Fr20Uhr As Date
 Dim Mo06Uhr As Date
 Dim Planwochenendebeginnzeit As Date
 Dim Name As String
 Dim Sonntag00UhrderbetreffendenKalenderwoche As Date
 Dim DerLetztedesVormonates As Date
 
Dim LC As Range
Set LC = ActiveSheet.UsedRange.SpecialCells(11)
 
   With Columns(1)
    
     Set rng = .Find("RZKontr:", LookIn:=xlValues)
        ' rng.Select
         Anf = rng.Offset(0, 3).Address
          
       Do
       With Rows(16)
            Set Fr = .Find("Fr", , xlValues, xlWhole)
              '  Fr.Select
                SuchedieWochenenden = Fr.Address
                            DatumdesFreitag = Fr.Offset(1, 0).Value
                            Fr20Uhr = DateAdd("h", 20, DatumdesFreitag)
                            Mo06Uhr = DateAdd("h", 58, Fr20Uhr)

Do

    For j = Fr.Column To Fr.Column + 2
          dasDatumindersiebtenZeile = Cells(17, j)

               Set D = Cells(rng.Row - 2, j)
                 '  D.Select
               Dim Dienstbeginn As Date
                   If IsNumeric(D) And D > 0 Then
                      Dienstbeginn = dasDatumindersiebtenZeile + D
                   End If

               Set C = Cells(rng.Row, j)
                  ' C.Select
               If IsNumeric(C) And C > 0 Then
                  Ez = dasDatumindersiebtenZeile + C

                            DatumdesFreitag = Fr.Offset(1, 0).Value
                            Fr20Uhr = DateAdd("h", 20, DatumdesFreitag)
                            Mo06Uhr = DateAdd("h", 58, Fr20Uhr)

             If Dienstbeginn > Fr20Uhr And Dienstbeginn < Mo06Uhr Or Ez > Fr20Uhr And Ez <  _
Mo06Uhr Then
                      ' MsgBox Name & "hat zwischen " & Fr20Uhr & "und " & Mo06Uhr & "also am  _
Plan WE Dienst"
                  
                  Select Case Dienstbeginn
                              Case Is > Fr20Uhr
                                   'Das PlanWe fängt um 20 Uhr oder später an = nimm diese Zeit  _
als Planwochenendebeginnzeit
                                    Planwochenendebeginnzeit = Dienstbeginn
                                    GoTo Die_PlanwochenendebeginnZeit_steht_fest
                              
                              Case Is < Fr20Uhr And Ez > Fr20Uhr
                                        Planwochenendebeginnzeit = Dienstbeginn
                                        GoTo Die_PlanwochenendebeginnZeit_steht_fest
                                        
                              Case Else
                              
                                 If IsNumeric(Cells(rng.Row, j + 1)) Then
                                    Planwochenendebeginnzeit = Cells(17, j + 1) + D.Offset(0, 1) _

                                 Else
                                   Planwochenendebeginnzeit = Cells(17, j + 2) + D.Offset(0, 2)
                                 End If
                   End Select
            
                          
Die_PlanwochenendebeginnZeit_steht_fest:

Sonntag00UhrderbetreffendenKalenderwoche = DateAdd("h", -116, Fr20Uhr)


           DerLetztedesVormonates = Cells(16, 4)
If Weekday(DerLetztedesVormonates, 2) = 7 Then

           GoTo KontrollieredieersteWoche
         Else
           
If Sonntag00UhrderbetreffendenKalenderwoche < DerLetztedesVormonates Then
           Name = Cells(rng.Row + 1, 1)
           MsgBox "Die Ruhezeit des " & Name & " kann nicht kontrolliert werden da nicht alle  _
Kalendertage - der ersten Woche in diesem Dienstplan - angezeigt werden"
           
           Else
           
KontrollieredieersteWoche:

    Dim Montag As Date
    Dim Dienstag As Date
    Dim Mittwoch As Date
    Dim Donnerstag As Date
    
    Montag = DatumdesFreitag - 4
    Dienstag = DatumdesFreitag - 3
    Mittwoch = DatumdesFreitag - 2
    Donnerstag = DatumdesFreitag - 1
    
    Dim Mo As Range
    Dim Startzeit As Date
    
    With Rows(16)
    'Do
          Set Mo = Cells(16, Fr.Column - 4)
            ' Mo.Select
                          
    Dim zaehler As Integer
    Dim LetztesDienstEnde As Date      ' bei Fennek Ez
    Dim ErsterDienst As Date           ' bei Fennek Sz
    
        Name = Cells(rng.Row + 1, 1)
        
                    Debug.Print Name
                    Debug.Print Fr20Uhr
                    Debug.Print Mo06Uhr
                    Debug.Print Planwochenendebeginnzeit
                    Debug.Print Sonntag00UhrderbetreffendenKalenderwoche
    
For zaehler = Mo.Column To Mo.Column + 5

  Cells(rng.Row, zaehler).Select   ' !!!!!Bitte um Hilfe!!!!!!!!!!!

             If LetztesDienstEnde < Montag Then LetztesDienstEnde = Montag

'             If ErsterDienst - LetztesDienstEnde >= 2 Then
'                 MsgBox "Durchgehender 48h Freitzeitblock ist vorhanden"
'                 GoTo nächstesWE
'             Else
'                  MsgBox "Durchgehender 48h Freitzeitblock ist n i c h t vorhanden"
'              End If
    


    
    
Next zaehler
                  
          End With
             End If
                End If

GoTo nächstesWE
           End If
               End If
                     Next j
nächstesWE:
   
Set Fr = .Find("Fr", Fr, xlValues, xlWhole)
  ' Fr.Select
          Loop Until SuchedieWochenenden = Fr.Address
End With

Set rng = .Find("RZKontr:", rng, xlValues, xlWhole)   ' hier Lösung von Nepumuk v. 16.12.18
  ' rng.Select
         Loop Until Anf = rng.Offset(0, 3).Address
End With
End Sub

Anfrage:
Bringe es aber nicht :-( zusammen dass geprüft wird ob eine durchgehende 48h Ruhezeit/Freizeitblock in dieser Woche vorhanden ist.

Wenn in der rng.Zeile ein Eintrag wie : "U", "NZG", "PFU", "SU", "PfU"
vorhanden ist darf dieser Tag von 00.00 bis 24.00 Uhr nicht als Freizeit gerechnet werden.

Besten Dank im voraus und verbleibe mfg
STeve