VBA code aanpassen automatisch cellen aanvullen

[samabert]

Hallo,

Onlangs hier een zeer mooie code gekregen die in een range controleert of er voor een bepaalde dag al een 2 x 1 en 2 x 2 is ingevuld als er 4 lege cellen overblijven in die range. Deze code werkt uitstekend, vult 1 of 2 automatisch aan wanneer nodig, maar op het werk willen ze nu toch wel iets gewijzigd hebben.

De controle werkt nog goed maar nu voor 5 lege cellen zijn. Ik heb de test gedaan met een message box die opkomt als de invoer in de resterende cellen moet stoppen, dit werkt.

Vraag:
In de plaats van de message box zou de code moeten komen dat hij de resterende lege cellen vult met een “X” In bijlage enkele voorbeelden hoe het eruitziet.
De al gedeeltelijk aangepaste code met de message box:

Option Explicit
Const lEmp As Long = 14

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range
    Dim i As Long, j As Long
    Dim cell As Range
    Dim rCell As Range


    If Intersect(Target, Range("B6:AF6").Resize(lEmp)) Is Nothing Then Exit Sub
    On Error Resume Next

    With Application
        .EnableEvents = False
        'ActiveSheet.Unprotect ""
        Target(1).Value = UCase(Target(1).Value)
        'Range("A3") = Now
        'Range("A5") = sUser
        'ActiveSheet.Protect ""

        Set Rng = Cells(6, Target.Column).Resize(lEmp)
        If .CountBlank(Rng) + .Min(.CountIf(Rng, 1), 2) + .Min(.CountIf(Rng, 2), 2) <= 5 And .CountBlank(Rng) > 0 Then 'kontrole werkt


            'Hier code die de resterende lege cellen vult met  "X"


            MsgBox "Stop filling", _
             vbInformation, "0000"

        End If
        .EnableEvents = True
    End With
End Sub

De oorspronkelijke code die het aanpassen van shift 1 en 2 automatisch aanpast.

Option Explicit
Const lEmp As Long = 14 'Aantal personen

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range
    Dim i As Long, j As Long
    
    If Intersect(Target, Range("B6:AF6").Resize(lEmp)) Is Nothing Then Exit Sub
    With Application
        .EnableEvents = False
        ActiveSheet.Unprotect "1234"
        Target(1).Value = UCase(Target(1).Value)
        Range("A3") = Now
        Range("A5") = sUser
        'Range("A5") = .UserName
        ActiveSheet.Protect "1234"
        Set Rng = Cells(6, Target.Column).Resize(lEmp)
        If .CountBlank(Rng) + .Min(.CountIf(Rng, 1), 2) + .Min(.CountIf(Rng, 2), 2) <= 4 And .CountBlank(Rng) > 0 Then
            For j = 1 To 2
                For i = 1 To 2 - .CountIf(Rng, j)
                    Rng(Evaluate("min(if(" & Rng.Address(0, 0) & "="""",row(1:" & lEmp & ")))")) = j
                Next
            Next
        End If
        .EnableEvents = True
    End With
End Sub

Ik hoop dat mijn uitleg voldoende is.
Alvast bedankt
Marc

 

[gast0660]

Uw vraag is voor mij niet echt duidelijk, maar misschien zo?

 Target.Offset(1, 0).Resize(.CountBlank(Rng)) = "X"

 

[samabert]

gast0660

Bedankt voor jouw reactie. Het zit in de goede richting, er komen (X) te staan maar nog niet helemaal juist . Het is inderdaad niet zo eenvoudig om uit te leggen.

De oorspronkelijke code controleerde voor een dag van de maand, voorbeeld K6:K19 of er bij het invullen van recupe, verlof enz. of er voor die dag 2 personen zijn voor de ochtend shift (1) en 2 voor de namiddag shift (2). Bij 4 lege cellen resterende en geen shift 1 & shift 2 ingevuld werd automatisch de 4 cellen opgevuld met 2 x getal 1 en 2 x getal 2.
Er kon ook voorkomen, voorbeeld iemand plaatst al 1 maal shift 1 in, er blijven dus 3 cellen opgevuld te worden. Deze werden opgevuld met nog 1 x shift 1 en 2 x shift 2.
Alle combinaties die resteren werden gecontroleerd en dusdanig opgevuld.

Deze code werkte voor dit opvullen volledig (code hieronder).

Set Rng = Cells(6, Target.Column).Resize(lEmp)
        If .CountBlank(Rng) + .Min(.CountIf(Rng, 1), 2) + .Min(.CountIf(Rng, 2), 2) <= 4 And .CountBlank(Rng) > 0 Then
            For j = 1 To 2
                For i = 1 To 2 - .CountIf(Rng, j)
                    Rng(Evaluate("min(if(" & Rng.Address(0, 0) & "="""",row(1:" & lEmp & ")))")) = j

Maar nu zou het gewijzigd moeten worden dat in plaats van 4 lege er nu 5 lege cellen moeten gecontroleerd worden, dit werkt al door “ <= 5 “ aangepast te hebben in de code.

Wat ik nu graag zou willen: In plaats automatisch verder aanvullen met shiften (1) en shiften (2) zoals in de eerste code, nu enkel opvullen met (X). Omdat de controle over 5 lege cellen gaat, zal je nu 5 keer een (X) moeten laten plaatsen.

Set Rng = Cells(6, Target.Column).Resize(lEmp)
        If .CountBlank(Rng) + .Min(.CountIf(Rng, 1), 2) + .Min(.CountIf(Rng, 2), 2) <= 5 And .CountBlank(Rng) > 0 Then 


            'Hier code die de resterende lege cellen na controle vult met  "X"

Als je in Test_FD_2 in range (K6:K19) verder invult met voorbeeld “V” zou je 5 keer (X) moeten krijgen in de 5 laatste lege cellen. Combinaties met “V”, 1x1, 2x1, 2x2, 3x1 en 2x2 in de cellen geeft dus ander cellen met (X). Als er voor die dag voorbeeld 2x shift (1) en 2x shift (2) al ingevuld is zal er maar 1 cel meer met een (X) opgevuld worden.




Ik hoop dat je mij kan helpen met deze uitleg, heb ook al iets geprobeerd maar niet met het gewenste resultaat.
Mvg.
Marc

 

[samabert]

Mijn probleem is opgelost, ik heb volgende regel toegevoegd en de laatste lege cellen worden nu gemarkeerd met "X"

Rng.SpecialCells(xlCellTypeBlanks).Value = "X"