• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Als cel waarde is "x" dan automatisch invoeren van getallen

Status
Niet open voor verdere reacties.
S

samabert

Gebruiker
Lid geworden
27 mrt 2010
Berichten
301
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.
=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"))))
Klik om te vergroten...

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
 

Bijlagen

  • Test_Shift1_Shift2.xlsm
    43,9 KB · Weergaven: 42
Test deze eens:
Code: 
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
        Target(1).Value = UCase(Target(1).Value)
        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
 
Laatst bewerkt:
@ Timshel,

Ongelooflijk knap gedaan!!!

Ik heb alle mogelijke combinaties getest en voor mij werkt het volledig en dat zonder die formule toestanden.
Ik ben hier super blij mee :thumb:

Met deze aanpassing heb ik nu nog wel een bijkomende vraag:
In mijn finale bestand had ik volgende code staan om de tijd wanneer er iets wijzigt en de User weer te geven van diegene die ingelogd heeft.

Code: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    
    Application.EnableEvents = False

    If Not Application.Intersect(Target, Range("B4:AF19")) Is Nothing Then

        
        ActiveSheet.Unprotect "1234"

        Range("A3") = Now()
        Range("A5") = sUser

        ActiveSheet.Protect "1234"

    End If
    
    Application.EnableEvents = True



End Sub

Ik heb geprobeerd van dit in te voegen in de code die jij hebt gegeven, echter dit lukt mij niet.
Kan dit nog aangepast worden?

Nogmaals heel erg bedankt voor jouw hulp.

Mvg.
Marc
 
De variabele sUser zou globaal gedeclareerd moeten zijn.
Ik heb het even anders gedaan.

Code: 
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") = .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
 
Timshel,

Het heeft even geduurd omdat ik het uitgebreid heb getest in mijn finale bestand en het werkt volledig. Datum, tijd en User worden netjes ingevuld.
Nogmaals, je bent heel erg bedankt voor deze mooie code :thumb:

Nog een prettig weekend.
Mvg.
Marc
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan