Microsoft Excel

Herbers Excel/VBA-Archiv

Schichtplan zusammenführen

Betrifft: Schichtplan zusammenführen von: Tobias
Geschrieben am: 14.11.2014 03:30:50

Guten Tag,

ich habe ein Problem mit Excel, bissher konnte ich mir immer selber Helfen oder habe google dazu missbraucht. Hat auch ziemlich viel gebracht und bissher stand mir noch nie was im weg. Habe mir Excel VBA selber bei gebracht, stoße aber jetzt an meine "Zeitlichen" grenzen. Ich bräuchte die Datei nämlich dringend.

Ich habe einen Schichtplan erstellt, der auf der einen Seite eine "Druckversion" hat und auf der anderen einen Urlaubsplan. Wenn man in dem Urlaubsplan bei dem Mitarbeiter ein "x" setzt wird dieser auf der Durckversion "Rot" markiert. Das funktioniert auch alles schon soweit. Nur fügt er die Namen nicht so zusammen wie ich das will. Zurzeit lass ich ihn über Loops die Farben auslesen und dann den Namen in die Übersicht schreiben. Nur sind die Namen nicht immer in der Selben Zeile, so wie es auf der Urlaubsseite gegliedert ist. Startet einfach die "FillUpSub" Function (Damit es nicht Sicherbar ist eine Function ...) und ihr seht wie es sich auf dem "Schichtplan" Tabellen Blatt zusammenführt. Aber wie gesagt, die Namen stehen nicht immer in der selben Reihe und das macht es unübersichtlich. Ich hätte es gerne wie auf der "Urlaubsplan" Tabelle.
Theoretisch genauso nur mit anderem Template und mit Namen anstatt Farben wenn ihr versteht ... Bitte um HILFE :(

Anhang: https://www.herber.de/bbs/user/93762.xlsm

MFG
Tobias

  

Betrifft: AW: Schichtplan zusammenführen von: Dieter Klemke
Geschrieben am: 14.11.2014 22:13:59

Hallo Tobias,

wenn ich dein Problem richtig verstanden habe, dann kannst du das mit dem folgenden Programm machen:

Sub FillUpSubNeu()
  Dim anfZeileKW As Long
  Dim anzKW As Long
  Dim bereichKW As Range
  Dim endZeileKW As Long
  Const indFrühschicht As Long = 40
  Const indNachtschicht As Long = 15
  Const indSpätschicht As Long = 37
  Dim k As Long
  Dim letzteSpalteU As Long
  Dim lfdJahr As Long
  Dim m As Long
  Dim s As Long
  Dim spalteKW As Long
  Dim spalteS As Long
  Dim spalteU As Long
  Dim t As Long
  Dim wsS As Worksheet
  Dim wsU As Worksheet
  Dim zeileS As Long
  Dim zeileU As Long
  
  Set wsS = ThisWorkbook.Worksheets("Schichtplan")
  Set wsU = ThisWorkbook.Worksheets("Urlaubsplan")
  ' Anzahl der vorhandenen Kalenderwochen des lfd. Jahres bestimmen
  lfdJahr = Year(Date)
  letzteSpalteU = wsU.Cells(2, wsU.Columns.Count).End(xlToLeft).Column
  For spalteU = 3 To letzteSpalteU Step 7
    If Year(wsU.Cells(4, spalteU)) > lfdJahr Then
      anzKW = (spalteU - 10) / 7 + 1
      Exit For
    End If
  Next spalteU
  For k = 1 To anzKW
    anfZeileKW = (k - 1) * 16 + 4
    endZeileKW = anfZeileKW + 11
    Set bereichKW = wsS.Range(wsS.Cells(anfZeileKW, "B"), _
                              wsS.Cells(endZeileKW, "H"))
    bereichKW.ClearContents
    spalteKW = (k - 1) * 7 + 3
    For t = 0 To 6 ' t läuft über die Tage einer KW
      spalteU = spalteKW + t
      For s = 0 To 2 ' s läuft über die 3 Schichtblöcke
        For m = 0 To 3 ' m läuft über die 4 Mitarbeiter eines Schichtblocks
          zeileU = 6 + 4 * s + m
          Select Case wsU.Cells(zeileU, spalteU).Interior.ColorIndex
            Case indFrühschicht
              zeileS = anfZeileKW + m
            Case indSpätschicht
              zeileS = anfZeileKW + 4 + m
            Case indNachtschicht
              zeileS = anfZeileKW + 8 + m
            Case Else
              zeileS = 0
          End Select
          If zeileS <> 0 Then
            wsS.Cells(zeileS, t + 2) = wsU.Cells(zeileU, "B")
          End If
        Next m
      Next s
    Next t
  Next k
End Sub
Viele Grüße
Dieter


  

Betrifft: AW: Schichtplan zusammenführen von: silencshadow
Geschrieben am: 18.11.2014 20:10:28

Hallo,

prinzipiell ist alles richtig gelöst und ich bedanke mich schon einmal im voraus! Habe aber dennoch eine kleine Frage an dich für eine Code Anpassung.

Habe mir den Code jetzt so umgeschrieben das er im Urlaubsplan alle mit "x" markierten Einträge Rot markiert, aber bin dennoch nicht ganz fertig und da brauche ich wieder deine Hilfe.

Erstmal mein veränderter Code:

Sub FillUpSubNeu()
  Dim anfZeileKW As Long
  Dim anzKW As Long
  Dim bereichKW As Range
  Dim endZeileKW As Long
  Const indFrühschicht As Long = 40
  Const indNachtschicht As Long = 15
  Const indSpätschicht As Long = 37
  Dim k As Long
  Dim letzteSpalteU As Long
  Dim lfdJahr As Long
  Dim m As Long
  Dim s As Long
  Dim spalteKW As Long
  Dim spalteS As Long
  Dim spalteU As Long
  Dim t As Long
  Dim wsS As Worksheet
  Dim wsU As Worksheet
  Dim zeileS As Long
  Dim zeileU As Long
  
  Set wsS = ThisWorkbook.Worksheets("Schichtplan")
  Set wsU = ThisWorkbook.Worksheets("Urlaubsplan")
  
    'wsS.Unprotect "1234"

  ' Anzahl der vorhandenen Kalenderwochen des lfd. Jahres bestimmen
  lfdJahr = Year(Date)
  letzteSpalteU = wsU.Cells(2, wsU.Columns.Count).End(xlToLeft).Column
  For spalteU = 3 To letzteSpalteU Step 7
    If Year(wsU.Cells(4, spalteU)) > lfdJahr Then
      anzKW = (spalteU - 10) / 7 + 1
      Exit For
    End If
  Next spalteU
  
  anzKW = 6 ' Anzahl auf 6 KW's Reduziert
  
  For k = 1 To anzKW
    anfZeileKW = (k - 1) * 16 + 4
    endZeileKW = anfZeileKW + 11
    Set bereichKW = wsS.Range(wsS.Cells(anfZeileKW, "B"), _
                              wsS.Cells(endZeileKW, "H"))
    bereichKW.ClearContents
    spalteKW = (k - 1) * 7 + 3
    For t = 0 To 6 ' t läuft über die Tage einer KW
      spalteU = spalteKW + t
      For s = 0 To 2 ' s läuft über die 3 Schichtblöcke
        For m = 0 To 3 ' m läuft über die 4 Mitarbeiter eines Schichtblocks
          zeileU = 6 + 4 * s + m
          Select Case wsU.Cells(zeileU, spalteU).Interior.ColorIndex
            Case indFrühschicht
              zeileS = anfZeileKW + m
            Case indSpätschicht
              zeileS = anfZeileKW + 4 + m
            Case indNachtschicht
              zeileS = anfZeileKW + 8 + m
            Case Else
              zeileS = 0
          End Select
          If zeileS <> 0 Then
            wsS.Cells(zeileS, t + 2) = wsU.Cells(zeileU, "B")
            
            If wsU.Cells(zeileU, spalteKW + t).Value = "x" Then
                wsS.Cells(zeileS, t + 2).Font.Color = "-16776961"
                Else
                    wsS.Cells(zeileS, t + 2).Font.ColorIndex = xlAutomatic
            End If
            
          End If
        Next m
      Next s
    Next t
  Next k
  
    'wsS.Protect "1234"
  
End Sub
Habe dazu aber noch eine Frage, kannst du mir den Code so ändern das er nur fortlaufend die nächsten 6 Wochen hin schreibt, also von HEUTE (KW 47) bis KW in 6 Wochen also KW 52 .. nächste Woche von KW 48 bis KW 53 etc. und irgendwie das der Code erkennt welche Woche zur Zeit ist und halt die Nächsten 6 Wochen ausrechnet und in den Schichtplan schreibt, so das immer nur 6 Wochen angezeigt werden, von der jetzigen KW. Zurzeit rechnet er mir die Jetzige Woche um eine verschoben, oder er schreibt sie falsch vom Urlaubsplan rüber. Also KW 47 ist bei ihm KW 48. Habe die Datei ja angefügt, kannst es dir ja da noch einmal anschauen. Am besten so, das ich mir die Anzahl der KW's bestimmen kann und ggf. auch wann er beginnt, also einmal eine Variable für "Jetzige KW" und eine für "KWStart = 23/2014" oder so. Also das das Modul auch für nächstes Jahr nahtlos funktioniert, will mir jede Woche einen neuen Plan drucken, dieser muss aber jedes mal neu generieren.


  

Betrifft: AW: Schichtplan zusammenführen von: silencshadow
Geschrieben am: 18.11.2014 22:23:33

Edit:

Habe leider kein Edit Knopf gefunden deswegen mach ich es so,
es wäre auch ganz nett wenn man irgendwie einstellen könnte wie viele Mitarbeiter genommen werden sollen, es kann nämlich sein, das 2 Mitarbeiter dazu kommen, dann sind auf 2 Schichten 5 und auf 1ner 4. Ist das irgendwie machbar, oder muss man dann mit dem Mitarbeiter "Leer" arbeiten? Bitte deswegen um eine Weitere anpassung.

MfG


  

Betrifft: AW: Schichtplan zusammenführen von: silencshadow
Geschrieben am: 19.11.2014 13:06:13

Oh, glaube habe den Haken bezüglich der nicht beantworteten Frage vergessen, finde immer noch kein edit knopf! lol


  

Betrifft: AW: Schichtplan zusammenführen von: Dieter Klemke
Geschrieben am: 19.11.2014 16:52:46

Hallo silencshadow (bei der ersten Anfrage war dein Name noch Tobias),

offenbar kommt der Appetit mit dem Essen. Als kleine Übung mache ich dir das mit dem Anfang bei der aktuellen Woche, auf längere Sicht musst du selbst programmieren lernen.
Zu der variablen Mitarbeiterzahl müsstest du noch einmal ein Beispiel hochladen, in dem zu sehen ist, was du dir vorstelltst.
Hier also das neue Programm (mit fester Mitarbeiterzahl):

Sub FillUpSubNeu_2()
  Dim anfKW As Long
  Dim anfZeileKW As Long
  Dim anzKW As Long
  Dim bereichKW As Range
  Dim endZeileKW As Long
  Const indFrühschicht As Long = 40
  Const indNachtschicht As Long = 15
  Const indSpätschicht As Long = 37
  Dim k As Long
  Dim letzteSpalteU As Long
  Dim lfdJahr As Long
  Dim m As Long
  Dim s As Long
  Dim spalteAnfKW As Long
  Dim spalteKW As Long
  Dim spalteS As Long
  Dim spalteU As Long
  Dim t As Long
  Dim wsS As Worksheet
  Dim wsU As Worksheet
  Dim zeileS As Long
  Dim zeileU As Long
  
  Set wsS = ThisWorkbook.Worksheets("Schichtplan")
  Set wsU = ThisWorkbook.Worksheets("Urlaubsplan")
  
  'wsS.Unprotect "1234"

  ' Anfangskalenderwoche
  anfKW = KW_nach_DIN(Date)
  lfdJahr = Year(Date)
  letzteSpalteU = wsU.Cells(2, wsU.Columns.Count).End(xlToLeft).Column
  For spalteU = 3 To letzteSpalteU Step 7
    If CLng(Right$(wsU.Cells(2, spalteU), 2)) = anfKW And _
       Year(wsU.Cells(4, spalteU)) = lfdJahr Then
      spalteAnfKW = spalteU
      Exit For
    End If
  Next spalteU
  
  anzKW = 6 ' Anzahl auf 6 KW's Reduziert
  
  For k = 1 To anzKW
    anfZeileKW = (k - 1) * 16 + 4
    endZeileKW = anfZeileKW + 11
    Set bereichKW = wsS.Range(wsS.Cells(anfZeileKW, "B"), _
                              wsS.Cells(endZeileKW, "H"))
    bereichKW.ClearContents
    spalteKW = spalteAnfKW + (k - 1) * 7
    For t = 0 To 6 ' t läuft über die Tage einer KW
      spalteU = spalteKW + t
      For s = 0 To 2 ' s läuft über die 3 Schichtblöcke
        For m = 0 To 3 ' m läuft über die 4 Mitarbeiter eines Schichtblocks
          zeileU = 6 + 4 * s + m
          Select Case wsU.Cells(zeileU, spalteU).Interior.ColorIndex
            Case indFrühschicht
              zeileS = anfZeileKW + m
            Case indSpätschicht
              zeileS = anfZeileKW + 4 + m
            Case indNachtschicht
              zeileS = anfZeileKW + 8 + m
            Case Else
              zeileS = 0
          End Select
          If zeileS <> 0 Then
            wsS.Cells(zeileS, t + 2) = wsU.Cells(zeileU, "B")
            If wsU.Cells(zeileU, spalteKW + t).Value = "x" Then
              wsS.Cells(zeileS, t + 2).Font.Color = "-16776961"
            Else
              wsS.Cells(zeileS, t + 2).Font.ColorIndex = xlAutomatic
            End If

          End If
        Next m
      Next s
    Next t
  Next k
  
  'wsS.Protect "1234"
End Sub
Die Kalenderwoche nach europäischer Norm bekommst du mit der folgenden Funktion:
Function KW_nach_DIN(Datum As Date) As Long
  'Berechnung der Kalenderwoche nach DIN 1355
  Dim anfDatum As Date
  
  anfDatum = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
  KW_nach_DIN = (Datum - anfDatum - 3 + (Weekday(anfDatum) + 1) Mod 7) \ 7 + 1
End Function
Viele Grüße
Dieter


 

Beiträge aus den Excel-Beispielen zum Thema "Schichtplan zusammenführen"