Schichtkalender

Hallo!
Ich habe in zwei Tagen Kleinstarbeit einen Schichtkalender (mit Hilfe von Euch) angefertigt und würde ihn gerne ein Stück weit, vielleicht später sogar komplett in meinem Schichtturnus automatisieren.
Den Kalender habe ich dazu mal zur Ansicht und evtl. Hilfestellung unter http://www.blueeye.ath.cx/Kalender.xls online gestellt.
In Zelle A1 kann man das Jahr durch ein Auswahlfeld verändern so dass sich der Kalender auf das gewählte Jahr anpasst. In Zelle E4 habe ich ein Auswahlfeld plaziert, in dem ich meine Schicht in der ich arbeiten muss auswählen kann. Da ich jeden Tag einzeln plazieren muss, würde ich dieses gerne automatisieren.
Meine Schichten folgen einem 5er Turnus der sich wöchentlich ändert...
Mo bis einschl. So Frühdienst ("I")
Mo bis einschl. Sa Spätdienst ("II"), So Dienstfrei (D)
Mo bis einschl. So Bereitschaftsdienst ("Sp")
Mo bis einschl. So Nachtdienst ("III")
Mo bis einschl. So Dienstfrei ("D")
Ich stelle mir das so vor... ich wähle zuerst das aktuelle Jahr und anschliessend wähle ich in Zelle E4 den ersten Schichttag (z.B. "I" für Frühdienst) aus und die Tabelle passt sich bis zum 31.Januar automatisch des o.g. Rhytmuses an. Das gleiche dann jeweils in der ersten Zelle des jeweiligen Monats, sprich J4, O4, T4 (...).
Ich möchte jeden Monat getrennt bearbeiten, da im Sommer der 5 Wochenrhytmus durch einen 4 Wochenrhytmus der 8 Wochen (ferienabhängig) andauert, unterbrochen wird.
Ist dies (wenn mgl. ohne VBA) lösbar?!
Ich wäre Euch für eine Hilfe sehr dankbar!!!
Gruß
Dietmar

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Schichtkalender

04.09.2005 11:29:40

Gerhard

AW: Schichtkalender

04.09.2005 11:56:59

Klaus-Dieter

AW: Schichtkalender

04.09.2005 18:05:30

Herbert

perfekter geht es nicht...

04.09.2005 19:06:16

Dietmar

hallo Dietmar,
du kannst es einmal testen...

Public Sub Schicht_eintr()
Dim sArr, i%, s As Byte, x$, a As Byte, wt As Byte
Dim w As Byte, z As Byte
sArr = Array("I", "II", "Sp", "III", "D")
On Error GoTo ende
With Selection
    x = .Value
    i = 5
    s = .Column
End With
  Select Case x
      Case sArr(0): a = 0
      Case sArr(1): a = 1
      Case sArr(2): a = 2
      Case sArr(3): a = 3
      Case sArr(4): a = 4
   End Select


With ActiveSheet
  wt = Weekday(.Cells(i, s - 4))
  If Selection.Value = "II" And wt = 2 Then Exit Sub
   If a = 1 And wt = 1 Then
     Cells(i, s) = sArr(4)
     i = i + 1
     a = a + 1
   End If

   If wt = 2 Then a = a + 1
   If a = 5 Then a = 0
   If a = 1 Then z = 7 Else: z = 1
   If wt = 1 Then z = 1

   Do
        .Cells(i, s) = sArr(a)
          wt = Weekday(.Cells(i, s - 4))
       i = i + 1
   Loop Until wt = z


   If a = 1 Then
     .Cells(i, s) = sArr(4)
     i = i + 1
   End If
   a = a + 1
   If a = 5 Then a = 0
   If a = 1 Then w = i - 1 Else: w = i

   Do Until i = w + 7
        .Cells(i, s) = sArr(a)
       i = i + 1
   Loop


   If a = 1 Then
     .Cells(i, s) = sArr(4)
    i = i + 1
   End If
   a = a + 1
   If a = 5 Then a = 0
   If a = 1 Then w = i - 1 Else: w = i


   Do Until i = w + 7
        .Cells(i, s) = sArr(a)
       i = i + 1
   Loop


   If a = 1 Then
     Cells(i, s) = sArr(4)
     i = i + 1
   End If
   a = a + 1
   If a = 5 Then a = 0
   If a = 1 Then w = i - 1 Else: w = i

   Do Until i = w + 7
        .Cells(i, s) = sArr(a)
       i = i + 1
   Loop


If a = 1 Then
     Cells(i, s) = sArr(4)
     i = i + 1
   End If
   a = a + 1
   If a = 5 Then a = 0
   If a = 1 Then w = i - 1 Else: w = i

   Do Until i = w + 7
        .Cells(i, s) = sArr(a)
       i = i + 1
       If i > 34 Then GoTo weiter
   Loop

    If a = 1 Then
     .Cells(i, s) = sArr(4)
     i = i + 1
   End If
   a = a + 1
   If a = 5 Then a = 0
   If a = 1 Then w = i - 1 Else: w = i

   Do Until i > 35
        .Cells(i, s) = sArr(a)
       i = i + 1
   Loop

weiter:
  For i = 32 To 34
   If Cells(i, s - 3) = "" Then
      Cells(i, s) = ""
    End If
  Next
End With
ende:
End Sub

https://www.herber.de/bbs/user/26286.xls
gruß Herbert

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread