Spalten wechseln VBA
04.06.2019 15:45:55
Wolfgang
den nachfolgenden Code erhielt ich hier aus diesem Forum. Er steckt hinter einem UF mit 10 CheckBoxes und 10 TextBoxes.
Er bewirkt, dass der jeweilige Text bei markierter CheckBox entweder in die Zielzelle Spalte C oder Spalte D eingetragen wird.
Wie kann der Code geändert werden, wenn ich anstelle Spalte C Spalte F "beschicken" möchte und anstatt Spalte D die Spalte G
beschickt haben möchte. Mir fehlt da der Überblick und würde mich sehr freuen, wenn ich da Hilfestellung bekommen könnte.
Herzlichen Dank schon jetzt und Viele Grüße - Wolfgang
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, 2).Value, vbMonday) 'Wochentag am 1. Datum
If Me.OptionButton2 = True Then 'Eintragen ohne Verschieben
Do
Do
If arrDienst(WT, 1) = True Then Cells(Zeile, 3) = arrDienst(WT, 2)
If arrDienst(WT, 3) = True Then Cells(Zeile, 4) = 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, 2)) Then Exit Do
Loop
Loop Until IsEmpty(Cells(Zeile, 2))
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 arrNew(WT, 2) "" And arrNew(WT, 3) "" Then
If bolSwitch = True Then
If arrDienst(WT, 3) = True Then Cells(Zeile, 4) = arrNew(WT, 2)
If arrDienst(WT, 1) = True Then Cells(Zeile, 3) = arrNew(WT, 3)
Else
If arrDienst(WT, 1) = True Then Cells(Zeile, 3) = arrNew(WT, 2)
If arrDienst(WT, 3) = True Then Cells(Zeile, 4) = arrNew(WT, 3)
End If
Else
If arrDienst(WT, 1) = True Then
Cells(Zeile, 3) = arrNew(WT, 2) & arrNew(WT, 3)
ElseIf arrDienst(WT, 3) = True Then
Cells(Zeile, 4) = arrNew(WT, 2) & arrNew(WT, 3)
End If
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, 2)) Then Exit Do
Loop
Loop Until IsEmpty(Cells(Zeile, 2))
End If
End Sub