Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1528to1532
1528to1532
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Kalender automatisieren -Terminserie

Forumthread: Kalender automatisieren -Terminserie

Kalender automatisieren -Terminserie
10.12.2016 09:52:03
Wolfgang
Hallo,
ich würde gerne einen Kalender automatisieren und Terminserien ermöglichen. Ich habe hierzu eine Musterdatei eingefügt (als Zip, da 323 kb).
Wenn auf dem UF z.B. das Häkchen vor montags vormittags steht und im nachstehenden Textfeld ein Name eingetragen ist, würde ich mir wünschen, dass der Name dann entsprechend in den Kalender eingetragen wird bzw. die Namen, die dann jeweils im markierten Textfeld stehen.
Es gibt Konstellationen, da würde ich mir eine Verschiebung um jeweils einen Termin je Woche wünschen (Rotation). Die Rotation wäre dann bezogen auf die markierten Wochentage
Z.B.:
1. Woche: Kollegin A Montagvormittag, Kollege B Dienstagnachmittag Kollege C Donnerstagnachmittag und Kollege D Freitagvormittag
Dann sollte in der zweiten Woche (beginnend immer mit der 1. KW des Jahres) der Plan wie folgt verschoben werden
Kollegin A Dienstagsnachmittag – Kollegin B Donnerstagsnachmittag – Kollege C Freitagvormittag und Kollege D Montagvormittag
Die Verschiebung würde dann wöchentlich für alle markierten Termine um einen Termin nach Vorne erfolgen (bis zum Jahresende). Vorausgesetzt, der entsprechende RadioButton ist markiert.
Könnte die Einrichtung einer solchen Terminserie denkbar sein?
Herzlichen Dank schon jetzt für die Rückmeldung.
Gruß – Wolfgang
https://www.herber.de/bbs/user/109965.zip
Anzeige

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Kalender automatisieren -Terminserie
10.12.2016 12:29:46
fcs
Hallo Wolfgang,
Könnte die Einrichtung einer solchen Terminserie denkbar sein?

Ja, das programmieren der erforderlichen Schleifen war allerdings eine kleine Sisyphusarbeit.
Nachfolgend das Makro für den Eintragen-Button.
LG
Franz 
Private Sub CommandButton1_Click()
'Schaltfläche "Eintragen"
Dim arrDienst(1 To 7, 1 To 4)
Dim J As Integer, K As Integer
Dim Zeile As Long, WT As Integer
Dim arrOld(1 To 7), arrNew(1 To 7, 1 To 3), NameLetzter As String
'Initialisieren Arraywerte für 7 Wochentage
For J = 1 To 7
arrDienst(J, 1) = False
arrDienst(J, 2) = ""
arrDienst(J, 3) = False
arrDienst(J, 4) = ""
Next
'Einlesen Userform-Daten
For J = 1 To 5
K = (J - 1) * 2 + 1
arrDienst(J, 1) = Me.Controls("CheckBox" & K).Object.Value
arrDienst(J, 2) = Me.Controls("TextBox" & K).Object.Value
arrDienst(J, 3) = Me.Controls("CheckBox" & K + 1).Object.Value
arrDienst(J, 4) = Me.Controls("TextBox" & K + 1).Object.Value
Next
Zeile = 5 'Zeile mit 1. Datum
WT = Weekday(Cells(Zeile, 1).Value, vbMonday) 'Wochentag am 1. Datum
If Me.OptionButton2 = True Then 'Eintragen ohne Verschieben
Do
Do
If arrDienst(WT, 1) = True Then Cells(Zeile, 2) = arrDienst(WT, 2)
If arrDienst(WT, 3) = True Then Cells(Zeile, 3) = arrDienst(WT, 4)
WT = WT + 1 'Wochentag Zähler erhöhen
If WT = 8 Then 'neue Woche beginnt
WT = 1 'Wochentag auf Montag setzen
End If
Zeile = Zeile + 1
If IsEmpty(Cells(Zeile, 1)) Then Exit Do
Loop
Loop Until IsEmpty(Cells(Zeile, 1))
ElseIf Me.OptionButton1 = True Then 'Eintragen mit Verschieben
'Dienstpladaten für 1. Woche ermitteln aus Eingabedaten
For J = 1 To 7
arrNew(J, 1) = arrDienst(J, 1) = True Or arrDienst(J, 3) = True
'Prüfen, ob Dienst an diesem Tag
If arrNew(J, 1) = True Then
If arrDienst(J, 1) = True Then
'Dienst vormittags
arrNew(J, 2) = arrDienst(J, 2)  'Name
arrNew(J, 3) = 2                'Spalte
Else
'Dienst nachmittags
arrNew(J, 2) = arrDienst(J, 4)  'Name
arrNew(J, 3) = 3                'Spalte
End If
Else
'kein Dienst
arrNew(J, 2) = arrDienst(J, 2)  '""
arrNew(J, 3) = 2                '0
End If
Next
'Eintragen Dienste
Do
Do
'Prüfen,  ob Dienst und ggf. Name am Vor./Nachmittag eintragen
If arrNew(WT, 1) = True Then Cells(Zeile, arrNew(WT, 3)) = arrNew(WT, 2)
WT = WT + 1 'Wochentag Zähler erhöhen
If WT = 8 Then 'neue Woche beginnt
WT = 1 'Wochentag auf Montag setzen
'Namen der Vorwoche in Array merken
For J = 1 To 7
arrOld(J) = arrNew(J, 2)
'Namen merken, der zuletzt in der Vor-Woche Dienst hatte
If arrNew(J, 2)  "" Then NameLetzter = arrNew(J, 2)
Next
'Namen um einen Tag mit Dienst verschieben
For J = 1 To 7
If arrNew(J, 1) = True Then 'Prüfen, ob am Wochentag Dienst
arrNew(J, 2) = NameLetzter
NameLetzter = arrOld(J) 'Namen aus Liste der Vorwoche übernehmen
End If
Next
End If
Zeile = Zeile + 1
If IsEmpty(Cells(Zeile, 1)) Then Exit Do
Loop
Loop Until IsEmpty(Cells(Zeile, 1))
End If
End Sub

Anzeige
AW: Kalender automatisieren -Terminserie
10.12.2016 14:35:29
Wolfgang
Hallo Franz,
tausend lieben Dank für die Ausarbeitung und Überlassung des Codes. Das freut mich riesig. In der Grundstruktur läuft der Code auch. Probleme bereitet er, wenn an einem Tag -vormittags und nachmittags- angehakt sind, dann trägt er den Nachmittag nicht ein -trifft nur bei RadioButton Verschieben um einen Termin- zu. Hättest Du da noch evtl. eine Idee?
Danke schon jetzt erneut und Gruß
Wolfgang
Anzeige
AW: Kalender automatisieren -Terminserie
11.12.2016 00:25:23
fcs
Hallo Wolfgang,
mit den folgenden Anpassungen funktioniert das Verschieben und wöchentlich Vertauschen des Dienstes auch bei Auswahl beider Dienste an einem Wochentag.
Gruß 
Private Sub CommandButton1_Click()
'Schaltfläche "Eintragen"
Dim arrDienst(1 To 7, 1 To 4)
Dim J As Integer, K As Integer
Dim Zeile As Long, WT As Integer
Dim arrOld(1 To 7, 1 To 2), arrNew(1 To 7, 1 To 3), NameLetzter(1 To 2) As String
Dim bolSwitch As Boolean
'Initialisieren Arraywerte für 7 Wochentage
For J = 1 To 7
arrDienst(J, 1) = False
arrDienst(J, 2) = ""
arrDienst(J, 3) = False
arrDienst(J, 4) = ""
Next
'Einlesen Userform-Daten
For J = 1 To 5
K = (J - 1) * 2 + 1
arrDienst(J, 1) = Me.Controls("CheckBox" & K).Object.Value
arrDienst(J, 2) = Me.Controls("TextBox" & K).Object.Value
arrDienst(J, 3) = Me.Controls("CheckBox" & K + 1).Object.Value
arrDienst(J, 4) = Me.Controls("TextBox" & K + 1).Object.Value
Next
Zeile = 5 'Zeile mit 1. Datum
WT = Weekday(Cells(Zeile, 1).Value, vbMonday) 'Wochentag am 1. Datum
If Me.OptionButton2 = True Then 'Eintragen ohne Verschieben
Do
Do
If arrDienst(WT, 1) = True Then Cells(Zeile, 2) = arrDienst(WT, 2)
If arrDienst(WT, 3) = True Then Cells(Zeile, 3) = arrDienst(WT, 4)
WT = WT + 1 'Wochentag Zähler erhöhen
If WT = 8 Then 'neue Woche beginnt
WT = 1 'Wochentag auf Montag setzen
End If
Zeile = Zeile + 1
If IsEmpty(Cells(Zeile, 1)) Then Exit Do
Loop
Loop Until IsEmpty(Cells(Zeile, 1))
ElseIf Me.OptionButton1 = True Then 'Eintragen mit Verschieben
'Dienstplandaten für 1. Woche ermitteln aus Eingabedaten
For J = 1 To 7
arrNew(J, 1) = arrDienst(J, 1) = True Or arrDienst(J, 3) = True
'Prüfen, ob Dienst an diesem Tag
If arrNew(J, 1) = True Then
'Dienst vormittags
arrNew(J, 2) = arrDienst(J, 2)  'Name
'Dienst nachmittags
arrNew(J, 3) = arrDienst(J, 4)  'Name
Else
'kein Dienst
arrNew(J, 2) = ""
arrNew(J, 3) = ""
End If
Next
'Eintragen Dienste
bolSwitch = False
Do
Do
'Prüfen,  ob Dienst und ggf. Name am Vor./Nachmittag eintragen
If arrNew(WT, 1) = True Then
If bolSwitch = True Then
If arrNew(WT, 2)  "" Then Cells(Zeile, 3) = arrNew(WT, 2)
If arrNew(WT, 3)  "" Then Cells(Zeile, 2) = arrNew(WT, 3)
Else
If arrNew(WT, 2)  "" Then Cells(Zeile, 2) = arrNew(WT, 2)
If arrNew(WT, 3)  "" Then Cells(Zeile, 3) = arrNew(WT, 3)
End If
End If
WT = WT + 1 'Wochentag Zähler erhöhen
If WT = 8 Then 'neue Woche beginnt
WT = 1 'Wochentag auf Montag setzen
'Namen der Vorwoche in Array merken
For J = 1 To 7
arrOld(J, 1) = arrNew(J, 2)
arrOld(J, 2) = arrNew(J, 3)
'Namen merken, der zuletzt in der Vor-Woche Dienst hatte
If arrNew(J, 2)  "" Or arrNew(J, 3)  "" Then
NameLetzter(1) = arrNew(J, 2)
NameLetzter(2) = arrNew(J, 3)
End If
Next
'Namen um einen Tag mit Dienst verschieben
For J = 1 To 7
If arrNew(J, 1) = True Then 'Prüfen, ob am Wochentag Dienst
arrNew(J, 2) = NameLetzter(1)
arrNew(J, 3) = NameLetzter(2)
NameLetzter(1) = arrOld(J, 1) 'Namen aus Liste der Vorwoche ü _
bernehmen
NameLetzter(2) = arrOld(J, 2) 'Namen aus Liste der Vorwoche ü _
bernehmen
End If
Next
bolSwitch = Not bolSwitch
End If
Zeile = Zeile + 1
If IsEmpty(Cells(Zeile, 1)) Then Exit Do
Loop
Loop Until IsEmpty(Cells(Zeile, 1))
End If
End Sub

Anzeige
AW: Kalender automatisieren -Terminserie
11.12.2016 07:21:25
Wolfgang
Hallo Franz,
erneut herzlichen Dank für Deine Rückmeldung und für die Zeit, die Du Dir erneut für mein Problem genommen hast. Ich habe den neuen Code getestet. Leider bedient er nun auch Termine, die in der Eingabemaske nicht vorgemerkt sind. Ich habe einmal versucht, dieses auf beigefügtem Screenshot zu veranschaulichen. Beginn laut Maske = Bernd Montagvormittag; Eintrag erfolgt in der ersten Woche dann Dienstagnachmittag. Einträge erfolgen in der Folge auch z.B. in Montagnachmittags, der laut Eingabemaske "nicht bedient" werden soll. Das passiert auch an anderen Wochentagen. Hättest Du da noch evtl. eine Idee? Danke schon jetzt auch wieder für Deine Rückmeldung.
Gruß - Wolfgang
Userbild
Anzeige
AW: Kalender automatisieren -Terminserie
11.12.2016 17:43:41
fcs
Hallo Wolgang,
nachfolgend der anzupassende Abschnitt des Makros, damit die Namen beim Verschieben jewils beim markierten Dienst (Vormittags/Nachmittag) eingetragen werden.
Das Verschieben funktioniert aber nicht, wenn du an einigen Wochentagen nur einen Dienst markierst und an anderen beide Dienste. Denn dabei werden 2 Namen auf Tage mit nur einem Dienst und 1 Name auf Tage mit 2 Diensten verschoben.
LG
Franz
                'Prüfen,  ob Dienst und ggf. Name am Vor./Nachmittag eintragen
If arrNew(WT, 1) = True Then
If arrNew(WT, 2)  "" And arrNew(WT, 3)  "" Then
If bolSwitch = True Then
If arrDienst(WT, 3) = True Then Cells(Zeile, 3) = arrNew(WT, 2)
If arrDienst(WT, 1) = True Then Cells(Zeile, 2) = arrNew(WT, 3)
Else
If arrDienst(WT, 1) = True Then Cells(Zeile, 2) = arrNew(WT, 2)
If arrDienst(WT, 3) = True Then Cells(Zeile, 3) = arrNew(WT, 3)
End If
Else
If arrDienst(WT, 1) = True Then
Cells(Zeile, 2) = arrNew(WT, 2) & arrNew(WT, 3)
ElseIf arrDienst(WT, 3) = True Then
Cells(Zeile, 3) = arrNew(WT, 2) & arrNew(WT, 3)
End If
End If
End If

Anzeige
Danke, Franz - das klappt!!
11.12.2016 19:23:35
Wolfgang
Hallo Franz,
vielen Dank erneut für Deine Arbeit! - Danke auch für die Hinweise bezüglich der "Namensverteilung". Ich habe die Eingabe getestet und den Donnerstagnachmittag leer gelassen, um dafür den Mittwochnachmittag einzugeben. In der Realität, erfolgt so eine saubere Verteilung über das ganze Jahr, den Mittwoch verschiebe ich manuell auf Donnerstagnachmittag und der Kalender ist super eingerichtet. Hab nochmals vielen Tausend Dank.
Einen schönen Abend noch und schon jetzt Frohe Feiertage, sowie alles erdenklich Gute für 2017!
Gruß - Wolfgang
Anzeige
Franz, eine Frage noch
12.12.2016 08:56:42
Wolfgang
Hallo Franz,
ich habe noch ein wenig weiter getestet und dabei noch einen Kalender entdecken können, der in Spalte A noch die KW anzeigt. Wie müsste ich Deinen Code verändern, wenn nun der Kalenderbezug auf Spalte B liegt? - Danke schon jetzt wieder für Deine Rückmeldung.
Gruß - Wolfgang
Anzeige
AW: Franz, eine Frage noch
13.12.2016 06:02:11
fcs
Hallo Wolfangang,
in allen Zeilen in denen der Ausdruck
Cells(Zeile, ?)
vorkommt - ? ist hier die Spaltennmmer - musst du die Nummer der SPalte um 1 erhöhen.
Gruß
Franz
Tausend Dank - hat erneut geklappt
13.12.2016 09:36:45
Wolfgang
Hallo Franz,
vielen Dank für Deine Rückmeldung. Ich habe den Code entsprechend angepasst und es klappt super.
Hab auch hierfür tausend Dank.
Herzliche Grüße
Wolfgang
Anzeige

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige