AW: VBA Bereich nach unten verschieben
01.08.2022 10:32:05
Yal
Moin Christian,
eine pfiffige und gar nicht so einfache Frage! (sonst hättest Du nicht so lang warten müssen)
Ich habe es so behandelt: wenn sich irgendwas in einer Spalte ändert, wird die gesmate Spalte neugesetzt.
Die Einträge die nicht A, B oder C sind, bleiben bestehen, alle andere sind geteilt in "wirkt, wie im Abteilung" und "verlängert Aufenthalt im Abt.". Im erste Zeile, also 1.1. ist immer der Startabteilung (nie "Urlaub", nie "projekt", ...) und der erste von n Tage in dieser Abteilung.
Folgende Code musst Du in den Codepane vom Blatt, wo diese Liste sind (auf dem Reiter unter rechtsklicken, "Code anzeigen")
Private AktAbteilung As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim EB As Range
Set EB = Range(Me.Range("D2"), Me.Cells(Rows.Count, 1).End(xlUp).Offset(0, 1))
If Not Intersect(Target, EB) Is Nothing Then
Application.EnableEvents = False
AktAbteilung = Target.EntireColumn.Cells(2) 'Wert in zweite Zeile der betrachtete Spalte
Refresh_Liste Intersect(EB, Target.EntireColumn)
Application.EnableEvents = True
End If
End Sub
Sub Refresh_Liste(Bereich As Range)
Dim Z As Range
Dim AnsatzTage As Long
Const cAbt = "A;B;C"
Const MaxTage = 10
'erste Abteilung lesen
AktAbteilung = Bereich.Cells(1)
'Liste erzeugen
For Each Z In Bereich
Select Case LCase(Z.Value)
'Ereignisse, die wie ein Tag in Abteilung zählen
Case "projekt", "schule", "was auch immer"
AnsatzTage = AnsatzTage + 1
'Ereignis, die "berlängern" (zählt wie nicht in der Abteilung)
Case "urlaub", "krank"
'passiert aber nichts
'sonst prüfe und setze die Abteilung
Case Else
If AnsatzTage >= MaxTage Then
AnsatzTage = Application.Max(0, AnsatzTage - MaxTage - 1)
AktAbteilung = GetNext(cAbt, AktAbteilung)
End If
Z.Value = AktAbteilung
AnsatzTage = AnsatzTage + 1
End Select
Next
End Sub
Private Function GetNext(Liste As String, AktValue As String) As String
Dim Arr
Dim i
Arr = Split(Liste, ";")
For i = 0 To UBound(Arr)
If AktValue = Arr(i) Then Exit For
Next
GetNext = Arr((i + 1) Mod (UBound(Arr) + 1))
End Function
Was Du noch anpassen müsste:
_ deine letzte Spalte fängt im Beispiel in Zelle D2:
Set EB = Range(Me.Range("D2"), Me.Cells(Rows.Count, 1).End(xlUp).Offset(0, 1))
dementsprechend von D2 auf F2 oder was auch immer.
_ die Abteilungsliste in Refresh_Liste ist festdefiniert: Const cAbt = "A;B;C"
Andere Namen, aber semikolon getrennt eintragen. Anzahl ist egal.
_ Const MaxTage = 10 ... muss ich nicht erklären.
_ Case "projekt", "schule", "was auch immer": die jeweilige Ereignisse in den Fälle (engl. "Case"), immer kleingeschrieben
viel Erfolg damit
VG
Yal