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