Hallo,
Korte tijd geleden een code gekregen van HSV die mij heel goed op weg heeft geholpen voor mijn probleem, maar ik loop nu volledig vast in de uitbreiding ervan.
In een planning is het de bedoeling dat er voor een bepaalde dag altijd 2 personen zijn voor shift 1 & 2 voor shift 2.
Om te voorkomen dat er voorbeeld die dag enkel verlof, récupe of iets anders wordt ingevuld en er dus geen 2 x 1 shift en 2 x 2 shift zullen zijn, ben ik begonnen met via volgende formule te controleren hoever de telling voor de shiften staat en via de code automatisch bij de laatste lege cellen, 1 en 2 verder in te vullen.
De telling is een vergelijk tussen de nog lege cellen en shift 1 & 2. Hieronder de formule voor shift1.
Dit werkt goed tot op zekere hoogte, maar geeft als resultaat niet altijd 2 x 1 en 2 x 2 shiften.
Kan dit via de bestaande VBA code verder aan te passen of moet ik dit via een andere manier oplossen?
In het voorbeeld staat meer uitleg en een rooster van wat nu al werkt en wat niet, ik hoop dat dit meer duidelijkheid geeft over mijn vraag.
Graag jullie hulp en alvast bedankt,
Marc
Korte tijd geleden een code gekregen van HSV die mij heel goed op weg heeft geholpen voor mijn probleem, maar ik loop nu volledig vast in de uitbreiding ervan.
In een planning is het de bedoeling dat er voor een bepaalde dag altijd 2 personen zijn voor shift 1 & 2 voor shift 2.
Om te voorkomen dat er voorbeeld die dag enkel verlof, récupe of iets anders wordt ingevuld en er dus geen 2 x 1 shift en 2 x 2 shift zullen zijn, ben ik begonnen met via volgende formule te controleren hoever de telling voor de shiften staat en via de code automatisch bij de laatste lege cellen, 1 en 2 verder in te vullen.
De telling is een vergelijk tussen de nog lege cellen en shift 1 & 2. Hieronder de formule voor shift1.
=ALS(EN(B21=0;B24=2);"A";ALS(EN(B21=1;B24=1);"B";ALS(EN(B21=1;B24=3);"C";ALS(EN(B21=0;B24=3);"D"))))
Dit werkt goed tot op zekere hoogte, maar geeft als resultaat niet altijd 2 x 1 en 2 x 2 shiften.
Kan dit via de bestaande VBA code verder aan te passen of moet ik dit via een andere manier oplossen?
Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim arr As Range, cl As Range
Application.EnableEvents = False
If Not Application.Intersect(Target, Range("B6:AF19")) Is Nothing Then
Target(1).Value = UCase(Target(1).Value)
Range("A3") = Now()
End If
Application.EnableEvents = True
For Each arr In Range("B6:B19,C6:C19,D6:D19,E6:E19").Areas
If arr(1).Offset(22).Value = "A" Then
For Each cl In arr
If cl = "" Then cl.Value = 2
Next cl
End If
Next arr
For Each arr In Range("B6:B19,C6:C19,D6:D19,E6:E19").Areas
If arr(1).Offset(20).Value = "A" Then
For Each cl In arr
If cl = "" Then cl.Value = 1
Next cl
End If
Next arr
'======================================================================================
For Each arr In Range("B6:B19,C6:C19,D6:D19,E6:E19").Areas
If arr(1).Offset(22).Value = "B" Then
For Each cl In arr
If cl = "" Then cl.Value = 2
Next cl
End If
Next arr
For Each arr In Range("B6:B19,C6:C19,D6:D19,E6:E19").Areas
If arr(1).Offset(20).Value = "B" Then
For Each cl In arr
If cl = "" Then cl.Value = 1
Next cl
'======================================================================================
End If
Next arr
For Each arr In Range("B6:B19,C6:C19,D6:D19,E6:E19").Areas
If arr(1).Offset(22).Value = "C" Then
For Each cl In arr
If cl = "" Then cl.Value = 2
Next cl
End If
Next arr
For Each arr In Range("B6:B19,C6:C19,D6:D19,E6:E19").Areas
If arr(1).Offset(20).Value = "C" Then
For Each cl In arr
If cl = "" Then cl.Value = 1
Next cl
End If
Next arr
Application.EnableEvents = True
End Sub
In het voorbeeld staat meer uitleg en een rooster van wat nu al werkt en wat niet, ik hoop dat dit meer duidelijkheid geeft over mijn vraag.
Graag jullie hulp en alvast bedankt,
Marc