Voor de gevorderden...

[blueberry013]

Ik zit met een probleem....

even schetsen...

op een pagina in excel (tempploegen)staan in de eerste kolom verschillende waarden (vb. 2 - 2.15 - 4.45,...). dit zijn de doorlooptijden.
op een andere pagina staan in de eerste rij ook verschillende waarden (6 - 22 - 6 - 22 - 6 - 22 - 6 - 20,...). dit zijn eigenlijk de starttijden van de werkploegen.

Wat is nu de bedoeling... dat er op de derde pagina een tabel gemaakt wordt waarbij de eerste doorlooptijd ingekleurd wordt naar gelang de grootte van het eerste getal... de volgende doorlooptijd wordt ingekleurd met een ander kleur.
Als de eindtijd van de eerste dag bereikt wordt (22) moet hij overgaan naar dinsdag beginuur (6).
Dit dient herhaald te worden voor alle doorlooptijden zdd ik een gekleurd overzicht krijg van alle doorlooptijden in functie van de dagen...

Ik denk dat dit voor zeer gevorderde gebruikers van vba is...


Kan er iemand mij helpen...
Ik heb de 3 pagina's er even bijgezet...

alvast bedankt!Bekijk bijlage Map1.xlsx

 

[Mark xl]

Hoi Blueberry,

Ik heb deze macro gemaakt en getest, en bij mij werkte het.
De code en de verwijzingen zijn op basis van het door jou bijgevoegde voorbeeldbestand.

Ik vul het schema in op het blad "tempagenda"
Ik heb uren afgerond naar boven op kwartieren, dat leek me het duidelijkste

Hopelijk werkt het bij jou ook ,anders laat het me weten.

Succes,
Mark.

Option Explicit
Const DAG_LENGTE As Long = 16
Const WEEK_START As String = "B26"

Private Enum wkDag
    wkMaandag
    wkDinsdag
    wkWoensDag
    wkDonderdag
    wkVrijdag
    wkZaterdag
    wkZondag
End Enum

Sub UrenInvullen()
'macro om de uren in te vullen obv het voorbeeldsheet
Dim InvulUren As Range

    ClearWeek
    
    With Sheets("tempdoorlooptijd")
         Set InvulUren = .Range("A1", .Range("A65535").End(xlUp))
    End With
    
    FillOutWeek InvulUren
    
    Set InvulUren = Nothing

End Sub

Sub FillOutWeek(ByVal ArgList As Range)
Dim List As Variant
Dim record As Long
Dim dag As wkDag
Dim over As Long
Dim nextcolor As Long

    List = ArgList.Resize(, 11)
    
    over = DAG_LENGTE * 4
    nextcolor = RGB(255, 255, 0)
    
    For record = LBound(List, 1) To UBound(List, 1)
    
        List(record, 1) = WorksheetFunction.Ceiling(List(record, 1) * 4, 1) 'ín kwartieren
        
        If List(record, 1) >= over Then
        
            Do While List(record, 1) >= over
            
                Sheets("tempagenda").Range(WEEK_START) _
                    .Offset((DAG_LENGTE * 4) - over, dag * 2) _
                    .Resize(over).Interior.Color = nextcolor
                List(record, 1) = List(record, 1) - (over)
                dag = dag + 1
                over = DAG_LENGTE * 4
                
                If dag > wkVrijdag Then Exit For
                
            Loop
        
        End If
        
        If List(record, 1) < over And List(record, 1) > 0 Then
    
            Sheets("tempagenda").Range(WEEK_START) _
                .Offset((DAG_LENGTE * 4) - over, dag * 2) _
                .Resize(List(record, 1)).Interior.Color = nextcolor
            over = over - List(record, 1)
        
        End If
        
        
        If nextcolor = RGB(255, 255, 0) Then
            nextcolor = RGB(200, 200, 200)
        Else
            nextcolor = RGB(255, 255, 0)
        End If
    
    Next
    
End Sub

Private Sub ClearWeek()

    With Sheets("tempagenda")
        .Range("B26", .Cells.SpecialCells(xlCellTypeLastCell)) _
            .Interior.ColorIndex = xlNone
    End With
    
End Sub

 

[blueberry013]

Hallo Mark!

Dit werkt zeeeer goed! er zijn nog 2 probleempjes...
Soms veranderen begin- en eind uur... dit was gebaseerd op 2 ploegen systeem zonder weekends... soms varieert het van 8 tot 17 u, soms drie ploegen (=24u)
soms zaterdag en zondag... de uren (6 - 22) worden automatisch weggeschreven aan de hand van mijn planning...
Is het mogelijk deze waarden variabel te maken?

En dan had ik nog een vraagje... In een 2-ploegen systeem zijn 78 uren beschikbaar. Stel dat de doorlooptijden hoger liggen dan dat het ploegensysteem toelaat zou hij een melding moeten geven (rood kleur of een pop-up dat het niet past). Is dit mogelijk???

Ik vind het wel enorm knap wat je al geschreven hebt... echt waar chapeau!!!

ENORM HARD BEDANKT AL!!!!!

groetjes
wim

 

[blueberry013]

en nog een vraagje... hoe kan ik dit overzetten naar de kolommen ernaast... (het gaat over 2 lijnen die ingepland worden)

groetjes

 

[Mark xl]

Wim,

Wat dacht je hiervan...?
Volgens mij is dit deels alweer een antwoord op je vragen...

even wat uitleg
Ik heb even in je sheet gekeken, en ik heb volgende verondersteld

Ik heb overigens de linker en rechter kolom per dag "ploeg1" en "ploeg2" genoemd. waarschijnlijk bedoel ik iets anders dan jij met ploegen bedoelt.

blad "tempploegen",rij 1 is het start-stopuren schema van ploeg 1
blad "tempploegen",rij 2 is het start-stopuren schema van ploeg 2

De macro past het invullen aan aan de door jou ingevulde start-stop uren per ploeg. leef je uit.

Blad "tempdoorlooptijd" kolom1 is het urenschema van ploeg 1, doorlopend
Blad "tempdoorlooptijd" kolom2 is het urenschema van ploeg 2, doorlopend

zorg overigens wel dat alle waarden in de cellen zijn opgeslagen als getal, zodat de SOM() functie werkt (da's een check in de macro)

per ploeg heb je verschillende kleuren.

kun je er een beetje mee uit de voeten?

ps. de code is een beetje gegroeid, maar ik heb ff geen zin om het wat leesbaarder te maken en het bijvoorbeeld in een klasse te zetten. Normaliter probeer ik nooit meer dan 2 nesting levels per procedure te krijgen, maar dan ben ik nog wel even aan het schuiven. hopelijk vergeef je het me.

Succes ermee..

Mark.

Option Explicit

Public Enum wkDag
    wkMaandag
    wkDinsdag
    wkWoensDag
    wkDonderdag
    wkVrijdag
    wkZaterdag
    wkZondag
End Enum

Sub UrenInvullen()
'    sheet "tempploegen"
'       rij 1  werkuren ploeg 1
'       rij 2  werkuren ploeg 2

'   sheet "tempdoorlooptijd"
'       kolom 1: looptijden ploeg 1
'       kolom 2: looptijden ploeg 2

    ClearWeek
    
    VulUrenVoorPloeg 1
    VulUrenVoorPloeg 2

End Sub

Sub VulUrenVoorPloeg(ByVal ploeg As Long)
'macro om de uren in te vullen obv het voorbeeldsheet
Dim InvulUren As Range
    
    With Sheets("tempdoorlooptijd")
         Set InvulUren = .Range(Chr(64 + ploeg) & "1", .Range(Chr(64 + ploeg) & "65535").End(xlUp))
    End With

    FillOutWeek InvulUren, ploeg
    
    Set InvulUren = Nothing

End Sub

Sub FillOutWeek(ByVal Urenlijst As Range, _
                ByVal ploeg As Long)

Dim WerkTijden As Variant
Dim List As Variant
Dim record As Long
Dim dag As Long
Dim over As Long
Dim nextcolor As Long
Dim Daglengte As Long
Dim Start As Range

    'range to array
    List = Urenlijst.Resize(, 1)
    
    WerkTijden = StartUren(ploeg)
    
    If Not IsArray(WerkTijden) Then
        MsgBox "Er zijn geen werkuren ingevuld voor ploeg " & ploeg
        Exit Sub
    End If
        
    If WorksheetFunction.Sum(List) > WorksheetFunction.Sum(WerkTijden) Then
    
        MsgBox "Er zijn meer uren voor ploeg" & ploeg & "ingevuld dan beschikbaar" & _
                vbCr & "De uren worden zo ver mogelijk ingevuld", vbInformation
    
    End If
    
    Daglengte = UrenNaarKwartier(WerkTijden(1, 2) - WerkTijden(1, 1))
    over = Daglengte
    Set Start = Sheets("tempagenda").Range(Chr(65 + ploeg) & 2 + UrenNaarKwartier(WerkTijden(1, 1)))
    
    nextcolor = volgendeKleur(ploeg, nextcolor)
    
    For record = LBound(List, 1) To UBound(List, 1)
    
        List(record, 1) = UrenNaarKwartier(List(record, 1))
        
        If List(record, 1) >= over Then
        
            Do While List(record, 1) >= over
            
                If over > 0 Then
                    Start.Offset(Daglengte - over) _
                         .Resize(over).Interior.Color = nextcolor
                    List(record, 1) = List(record, 1) - over
                End If
                dag = dag + 1
                
                'feestdagen(lege dagen) of dagen waar starttijd = eindtijd
                If dag * 2 + 1 < UBound(WerkTijden, 2) Then
                
                    Do While WerkTijden(1, dag * 2 + 1) = WerkTijden(1, dag * 2 + 2)
                        dag = dag + 1
                        If (dag * 2) > UBound(WerkTijden, 2) Then Exit Do
                    Loop
                
                End If
                
                If (dag * 2) >= UBound(WerkTijden, 2) _
                    Or dag > wkZondag Then
                    
                    Exit For
                    
                End If
                
                Daglengte = UrenNaarKwartier(WerkTijden(1, dag * 2 + 2) - WerkTijden(1, dag * 2 + 1))
                over = Daglengte
                
                Set Start = Sheets("tempagenda").Range(Chr(65 + ploeg + (dag * 2)) & 2 + UrenNaarKwartier(WerkTijden(1, dag * 2 + 1)))
                
            Loop
        
        End If
        
        If List(record, 1) < over And List(record, 1) > 0 Then
    
            Start.Offset((Daglengte) - over) _
                 .Resize(List(record, 1)).Interior.Color = nextcolor
            over = over - List(record, 1)
        
        End If
        
        nextcolor = volgendeKleur(ploeg, nextcolor)
    
    Next
    
End Sub

Private Function StartUren(ByVal ploeg As Long) As Variant

    With Sheets("tempploegen")
    
        Select Case ploeg
            Case 1
                StartUren = .Range("A1", .Range("IV1").End(xlToLeft))
            Case 2
                StartUren = .Range("A2", .Range("IV2").End(xlToLeft))
            Case Else
                MsgBox "Er worden slechts twee ploegen ondersteund", _
                        vbExclamation
        End Select
    
    End With

End Function

Private Function UrenNaarKwartier(ByVal Uren As Double) As Long
    UrenNaarKwartier = WorksheetFunction.Ceiling(Uren * 4, 1)
End Function

Private Sub ClearWeek()

    With Sheets("tempagenda")
        .Range("B26", .Cells.SpecialCells(xlCellTypeLastCell)) _
            .Interior.ColorIndex = xlNone
    End With
    
End Sub

Private Function volgendeKleur(ploeg As Long, _
                               huidigekleur As Long) As Long

    If ploeg = 1 Then
    
        'ploeg 1
        If huidigekleur = RGB(255, 255, 0) Then
            'donkerder grijs
            volgendeKleur = RGB(200, 200, 200)
        Else
            'geel
            volgendeKleur = RGB(255, 255, 0)
        End If
    
    Else
        
        'ploeg 2
        If huidigekleur = RGB(230, 230, 230) Then
            'blauwgroen
            volgendeKleur = RGB(0, 255, 255)
        Else
            'lichtgrijs
            volgendeKleur = RGB(230, 230, 230)
        End If

    End If

End Function

 

[blueberry013]

Dit is dus echt bangelijk!!!!!! echt ni normaal!!! Dit is compleet wat ik zocht!!!!!! Nu het nog ingewerkt krijgen in mijn afgewerkt bestand!

Je kan echt niet geloven hoe dankbaar ik u ben!!!!


SUPER!!!!

Bedankt Mark!

 

[blueberry013]

Hallo Mark!

Ik zit met nog 1 probleempje... Ik heb jouw sublieme macro in mijn bestand ingewerkt, maar als de macro start geeft hij de melding dat er meer uren voor ploeg 1 zijn, zelfde voor ploeg 2, terwijl dit eigenlijk niet zo is...
als ik dan op ok klik vult hij alles wel in, maar het zou eerder omgekeerd moeten zijn.
Ik dacht de hele file door te sturen maar is te groot voor naar hier te sturen...

Ik doe waarschijnlijk iets vrij dom, maar ik zie het dus niet...

groetjes
wim

 

[Mark xl]

Ha wim!

Ik heb iets fout gedaan denk ik
Ik doe in die macro: WorksheetFunction.Sum(List) > WorksheetFunction.Sum(WerkTijden)
Maar werktijden is een bereik van b.v. 6-22 voor maandag, maar 6+22 = 28 uur! en dat klopt natuurlijk niet.

Je kunt de regels

    If WorksheetFunction.Sum(List) > WorksheetFunction.Sum(WerkTijden) Then
    
        MsgBox "Er zijn meer uren voor ploeg" & ploeg & "ingevuld dan beschikbaar" & _
                vbCr & "De uren worden zo ver mogelijk ingevuld", vbInformation
    
    End If

uitschakelen door er tijdelijk even quotejes voor te zetten ( ' ), of ze te verwijderen, de invul macro controleert toch zelf of het past of niet.
dan zal Ik morgen laten weten hoe ik dat op ga lossen.

De Groeten!

 

[blueberry013]

Ik heb het probleem kunnen vinden... oplossen is iets anders...

Het probleem is dat hij de gegevens voor tempploegen uit een andere worksheet kopieert en plakt in tempploegen. Probleem is die getallen niet omzet naar "getallen". Heb geprobeerd via celeigenschappen, maar dit lukt dus niet...
als ik dubbelklik in de cel zet hij het wel om naar een getal...

nog een beetje verder proberen...misschien krijg ik het toch klaar.

groetjes

 

[blueberry013]

GELUKT!!!!

ik wil jou toch nog eens enorm bedanken voor het compleet uitschrijven hiervan!!
het zou anders nooit gelukt zijn!

bedankt!!!

 

[Mark xl]

Mooi!
Zet de vraag op opgelost, zodat de andere helpers deze vraag over kunnen slaan.

 

[blueberry013]

Hallo Mark,

Ik heb een vraagje voor u... Ik heb mijn bestandje helemaal herschreven, maar de omzetting naar deze oplossing lukt niet...
Het is een stuk uitgebreider geworden en met mijn beperkte kennis krijg ik het niet voor elkaar...
Nu is mijn vraag naar u of u me hier (weer) even mee kan helpen?
Ik krijg het bestand (door de grootte) hier niet geupload...

alvast bedankt,
groetjes Wim

 

[Mark xl]

Wim,

kun je niet een testbestandje maken?

dan verwijder je zoveel mogelijk data en niet ter zake doende macro's
dat moet toch wel lukken?

Mark.

 

[blueberry013]

Dag Mark,

Ik geraak max. op 200kb :-$
kan ik het misschien in mijn dropbox zetten?

groetjes
wim

 

[blueberry013]

Bekijk bijlage Planning Sivafrost.xlsxBekijk bijlage Grafisch Ishida.xlsxBekijk bijlage PloegIsh.xlsxBekijk bijlage QueryPloegIsh.xlsx

Dag Mark,

Dit zijn mijn modules....

Sub Knop1_Klikken()

    On Error Resume Next
    
    Application.ScreenUpdating = False
        
    'Sheets("Ploegen").Visible = True
    'Sheets("Grafisch Ishida").Visible = True
    'Sheets("Grafisch Multipond").Visible = True
    'Sheets("Query Grafisch Ishida").Visible = True
    'Sheets("Query Grafisch Multipond").Visible = True
    'Sheets("PloegIsh").Visible = True
    'Sheets("PloegMulti").Visible = True
    
    'If Weeknummer.Value = "" Then
    'MsgBox ("Gelieve weeknummer in te vullen"), vbOKOnly
    'Else
    
    'Dim c As Integer

    'c = FormPlanning.Weeknummer.Value
       
    'ActiveWorkbook.RefreshAll

    'Sheets("Ploegen").Select
    'ActiveSheet.ListObjects("Tabel3").Range.AutoFilter Field:=1, Criteria1:= _
        c
    'Sheets("Ploegen").Select
    'Application.Goto Reference:="Tabel3"
    'Selection.SpecialCells(xlCellTypeVisible).Select
    'Selection.Copy
    'Sheets("PloegIsh").Select
    'Range("A1").Select
    'ActiveSheet.Paste
    'Columns("A:E").Select
    'Application.CutCopyMode = False
    'Selection.Delete Shift:=xlToLeft
    'Range("A1").Select
    
    'Sheets("Query Grafisch Ishida").Select
    'ActiveSheet.ListObjects("TabGrafIsh").Range.AutoFilter Field:=1, Criteria1 _
        := 'c
    'Application.Goto Reference:="TabGrafIsh"
    'Selection.SpecialCells(xlCellTypeVisible).Select
    'Selection.Copy
    'Sheets("QueryPloegIsh").Select
    'Range("A1").Select
    'ActiveSheet.Paste
    
    
    'UrenInvullen

End Sub

Option Explicit

Public Enum wkDag
    wkMaandag
    wkDinsdag
    wkWoensDag
    wkDonderdag
    wkVrijdag
    wkZaterdag
    wkZondag
End Enum

Sub UrenInvullen()
'    sheet "tempploegen"
'       rij 1  werkuren ploeg 1
'       rij 2  werkuren ploeg 2

'   sheet "tempdoorlooptijd"
'       kolom 1: looptijden ploeg 1
'       kolom 2: looptijden ploeg 2

    ClearWeek
    
    VulUrenVoorPloeg 1
    VulUrenVoorPloeg 2

End Sub

Sub VulUrenVoorPloeg(ByVal ploeg As Long)
'macro om de uren in te vullen obv het voorbeeldsheet
Dim InvulUren As Range
    
    With Sheets("tempdoorlooptijd")
         Set InvulUren = .Range(Chr(64 + ploeg) & "1", .Range(Chr(64 + ploeg) & "65535").End(xlUp))
    End With

    FillOutWeek InvulUren, ploeg
    
    Set InvulUren = Nothing

End Sub

Sub FillOutWeek(ByVal Urenlijst As Range, _
                ByVal ploeg As Long)

Dim WerkTijden As Variant
Dim List As Variant
Dim record As Long
Dim dag As Long
Dim over As Long
Dim nextcolor As Long
Dim Daglengte As Long
Dim Start As Range

    'range to array
    List = Urenlijst.Resize(, 1)
    
    WerkTijden = StartUren(ploeg)
    
    If Not IsArray(WerkTijden) Then
        MsgBox "Er zijn geen werkuren ingevuld voor ploeg " & ploeg
        Exit Sub
    End If
        
    If WorksheetFunction.Sum(List) > WorksheetFunction.Sum(WerkTijden) Then
    
        MsgBox "Er zijn meer uren voor ploeg" & ploeg & "ingevuld dan beschikbaar" & _
                vbCr & "De uren worden zo ver mogelijk ingevuld", vbInformation
    
    End If
    
    Daglengte = UrenNaarKwartier(WerkTijden(1, 2) - WerkTijden(1, 1))
    over = Daglengte
    Set Start = Sheets("tempagenda").Range(Chr(65 + ploeg) & 2 + UrenNaarKwartier(WerkTijden(1, 1)))
    
    nextcolor = volgendeKleur(ploeg, nextcolor)
    
    For record = LBound(List, 1) To UBound(List, 1)
    
        List(record, 1) = UrenNaarKwartier(List(record, 1))
        
        If List(record, 1) >= over Then
        
            Do While List(record, 1) >= over
            
                If over > 0 Then
                    Start.Offset(Daglengte - over) _
                         .Resize(over).Interior.Color = nextcolor
                    List(record, 1) = List(record, 1) - over
                End If
                dag = dag + 1
                
                'feestdagen(lege dagen) of dagen waar starttijd = eindtijd
                If dag * 2 + 1 < UBound(WerkTijden, 2) Then
                
                    Do While WerkTijden(1, dag * 2 + 1) = WerkTijden(1, dag * 2 + 2)
                        dag = dag + 1
                        If (dag * 2) > UBound(WerkTijden, 2) Then Exit Do
                    Loop
                
                End If
                
                If (dag * 2) >= UBound(WerkTijden, 2) _
                    Or dag > wkZondag Then
                    
                    Exit For
                    
                End If
                
                Daglengte = UrenNaarKwartier(WerkTijden(1, dag * 2 + 2) - WerkTijden(1, dag * 2 + 1))
                over = Daglengte
                
                Set Start = Sheets("tempagenda").Range(Chr(65 + ploeg + (dag * 2)) & 2 + UrenNaarKwartier(WerkTijden(1, dag * 2 + 1)))
                
            Loop
        
        End If
        
        If List(record, 1) < over And List(record, 1) > 0 Then
    
            Start.Offset((Daglengte) - over) _
                 .Resize(List(record, 1)).Interior.Color = nextcolor
            over = over - List(record, 1)
        
        End If
        
        nextcolor = volgendeKleur(ploeg, nextcolor)
    
    Next
    
End Sub

Private Function StartUren(ByVal ploeg As Long) As Variant

    With Sheets("tempploegen")
    
        Select Case ploeg
            Case 1
                StartUren = .Range("A1", .Range("IV1").End(xlToLeft))
            Case 2
                StartUren = .Range("A2", .Range("IV2").End(xlToLeft))
            Case Else
                MsgBox "Er worden slechts twee ploegen ondersteund", _
                        vbExclamation
        End Select
    
    End With

End Function

Private Function UrenNaarKwartier(ByVal Uren As Double) As Long
    UrenNaarKwartier = WorksheetFunction.Ceiling(Uren * 4, 1)
End Function

Private Sub ClearWeek()

    With Sheets("tempagenda")
        .Range("B26", .Cells.SpecialCells(xlCellTypeLastCell)) _
            .Interior.ColorIndex = xlNone
    End With
    
End Sub

Private Function volgendeKleur(ploeg As Long, _
                               huidigekleur As Long) As Long

    If ploeg = 1 Then
    
        'ploeg 1
        If huidigekleur = RGB(128, 73, 128) Then
            'rose
            volgendeKleur = RGB(255, 73, 128)
        Else
            'purper
            volgendeKleur = RGB(128, 73, 128)
        End If
    
    Else
        
        'ploeg 2
        If huidigekleur = RGB(173, 216, 230) Then
            'paars
            volgendeKleur = RGB(238, 174, 238)
        Else
            'blauw
            volgendeKleur = RGB(173, 216, 230)
        End If

    End If

End Function

Even de situatie misschien ook schetsen...

Bedoeling is dus opvullen van die tabel...
van 10u tot 10u24, 18u tot 18u40 en 2u tot 2u40 is pauze (afhankelijk uiteraard van de waarde in de cel) (zou geel gekleurd moeten worden) - dan is het afwisselend een verschillende kleur (paars - lichtblauw) om de uren op te vullen. --> in kolom 3 op sheet Grafisch Ishida

In kolom 2 (Grafisch Ishida) zouden opeenvolgende nummers moeten komen (van pagina QueryPloegIsh kolom 1) - kolom 2 zijn de cijfers die gebruikt dienen te worden voor de opvulling (zijn uren) als de kleur in kolom 3 verandert (buiten uiteraard de pauzes, die dienen niet genummerd te worden). Deze zouden in kolom ter hoogte van de kleurverandering moeten kome...

Er is nog een tweede blad dat ik niet bijgevoegd heb, maar daar zijn de namen Grafisch Multipond - Query Grafisch Multipond - PloegMulti - QueryPloegMulti. Daar geldt eigenlijk hetzelfde principe.

Ik weet niet of het u gaat lukken, want het is nogal uitgebreid, denk ik? maar mijn kennis van vba is uiteraard zeer beperkt.

Alvast bedankt om het te willen bekijken.

Groetjes
Wim


Kan u hier iets mee?