Blauwe cellen met rode tekst tellen

[edmoor]

En wat bedoel je met "Verlopen"?
Een cel waar een datum staat die voor vandaag ligt?

 

[Severijns]

Edmoor,

Met verlopen bedoel ik het volgende:
De datum in de kolommen geven per respectievelijk scholing aan wanneer deze voltooid is.
Op rij 6 staat, voor zover van toepassing, per scholing hoelang deze geldig is.
Afhankelijk van de datum afronding en de geldigheidsduur kleurt tekst rood.
Dat gebeurt inderdaad pas wanneer de datum kleiner is dan vandaag.

Rob

 

[Severijns]

Kleine aanvulling op de laatste regel.

Dat gebeurt inderdaad pas wanneer de datum voltooiing + de geldigheidsduur kleiner is dan vandaag.

Rob

 

[edmoor]

Ik vind het heel lastig controleren, maar voer deze eens uit en kijk dan in de cellen H1017 en H1018.
Volgens mij kloppen die aantallen.
De code vult wel H1017 t/m CZ1017 en H1018 t/m CZ1018.

Sub TellenMaar()
    For x = 1 To 2
        Select Case x
            Case 1: klr = "C4"
            Case 2: klr = "C5"
        End Select
        
        For i = 8 To 104
            Select Case x
                Case 1: Ant = Cells(1017, i).Address(0, 0)
                Case 2: Ant = Cells(1018, i).Address(0, 0)
            End Select
            
            cellen = Split(Cells(13, i).Address, ":")(0) & ":" & Split(Cells(1013, i).Address, ":")(0)
            On Error Resume Next
            Set Rng = Range(cellen).SpecialCells(xlCellTypeConstants)
            aantal = 0

            If Not Rng Is Nothing Then
                For Each cl In Rng
                    If cl.DisplayFormat.Interior.Color = Range(klr).Interior.Color And cl.DisplayFormat.Font.Color = Range(klr).Font.Color Then
                        If IsDate(cl.Value) And cl.Value < Date Then
                            aantal = aantal + 1
                        End If
                    End If
                Next
            End If
            
            On Error GoTo 0
            Range(Ant).Value = aantal
            Set Rng = Nothing
        Next i
    Next x
End Sub

 

[Severijns]

Edmoor,

Harstikke bedankt. :thumb:
Dit lijkt inderdaad goed te werken.
Ik zal nog even testen in het originele document maar verwacht wel dat het goed zal gaan.
Dit had ikzelf nooit kunnen bedenken.
Ik laat nog wel even weten of ik nog ergens tegenaan loop maar voor nu kan ik mijn vraag op opgelost zetten.
Hier ben ik heel erg blij mee !!!

Rob

 

[Severijns]

Edmoor,

Ik heb jouw code getest in het originele document en voor zover ik kan zien werken alle berekeningen perfect :thumb:

Het uitvoeren van de code neemt nu zo'n 16 sec in beslag en dat is helaas te lang om bij iedere wijziging van een datum e.e.a. te laten her-berekenen dus ik denk dat ik daarvoor een knop ga maken die de macro "TellenMaar" uitvoert.
Dan beperk is in elk geval niet het gebruiksgemak want niemand zit te wachten op "lange" wachttijden tussen de invoer door.
Of weet jij toevallig hoe de wachttijd kan worden verkort tot aanvaardbare proporties?

Nu nog kijken of ik iets kan gaan begrijpen van de code die ik van jou gekregen heb.
Kleine wijzigingen aanbrengen lukt mij nog wel en nu stapje voor stapje kijken of ik er meer van kan gaan leren begrijpen.
Hoe dan ook ik ben heel erg blij met jouw oplossing !!!
Bedankt !

Rob

 

[edmoor]

Ok dan
Hele bevalling geweest voor je

Wat betreft de doorlooptijd, het hele te bekijken gebied is maximaal 96 x 1006 = 96576 cellen dus of dat veel sneller kan betwijfel ik.
Wel kan je m'n eerdere ideetje van het modeless Bezig schermpje er bij in bouwen.
Het tonen dat 'ie bezig is geeft een andere ervaring dan alleen maar wachten.

Overigens doet 'ie het op mijn PC in 2 seconden, maar dat is denk ik geen eerlijke vergelijking

 

[Severijns]

Edmoor,

Een bevalling is het zeker geweest. Zou bijna zeggen dat het kindje in een stuitligging lag en dat een keizersnede nodig was om het kindje goed ter wereld te brengen.
Jouw idee om het Modeless "Bezig" schermpje er bij in te zetten ga ik zeker opvolgen.:thumb:

Dat hij er bij jou slechts 2 sec over doet komt misschien omdat er in het originele bestand meer code en data zit dan in het bestand dat ik gepost heb.
Ik zal kijken of ik daar ook nog wat in kan aanpassen zodat het misschien sneller gaat.
Het door mij geposte bestand was op mijn laptop ook beduidend sneller.
Zelf beschik ik over een 2 jaar oude (gaming) laptop met een I7 processor, 32 Gb geheugen, een "snelle" dedicated videokaart en een 256 Gb SSD schijf. Niet de slechtste specificaties. Al zeg ik het zelf.
Het originele bestand wil ik straks via het intranet netwerk beschikbaar stellen aan de gebruikers en hoop dat de bandbreedte niet te veel extra vertraging gaat geven maar dat ga ik van de week even uitproberen.

Groeten,

Rob

 

[edmoor]

Die laptop zal sneller zijn dan mijn PC, al klaag ik niet.
Dat schermpje is inderdaad belangrijk, dat scheelt echt qua gebruikers ervaring.

 

[Severijns]

Edmoor,

Intussen het "Bezig" schermpje toegevoegd en een knop (CommandButton) die het berekenen middels jouw code start.
Zelf ook nog wat kleine aanpassingen aan jou code kunnen aanbrengen waardoor ik ook kan laten berekenen welke scholingen qua datums wel voldoen aan het criterium "Current" of te wel "Niet verlopen"
Was best wel blij dat mij dat gelukt is.

Er stond nog een Private Sub Worksheet_Calculate() in mijn VBA code die naar meerdere worksheets verwees en die heb ik niet als langer actief neergezet. Deze zorgde namelijk voor behoorlijk wat vertraging in het berekenen.
Voor de rest werkt jouw code naar wens.:thumb:

Wat mij niet is gelukt, is om de berekening zodanig te laten uitvoeren dat het resultaat filter afhankelijk is en verborgen rijen niet worden meegeteld. Zeg maar net zoals bij

=SUBTOTAAL(109;H$13:H$1013)

Ik weet niet hoe lastig dat is maar wellicht is dit een nieuwe vraag in het forum waard.

Nogmaals bedankt voor je hulp! en niet te vergeten de ondersteuning van de overige forumleden.

Rob

 

[edmoor]

Probeer dat eens zo:

If Not Rng Is Nothing Then
    For Each cl In Rng
        [COLOR="#FF0000"]If Not cl.Rows.Hidden Then[/COLOR]
            If cl.DisplayFormat.Interior.Color = Range(klr).Interior.Color And cl.DisplayFormat.Font.Color = Range(klr).Font.Color Then
                If IsDate(cl.Value) And cl.Value < Date Then
                    aantal = aantal + 1
                End If
            End If
        [COLOR="#FF0000"]End If[/COLOR]
    Next
End If

NB:
Niet getest, maar in die richting moet je het zoeken.

 

[Severijns]

Edmoor,

Dit werkt perfect ! :thumb:
Hoef de vraag niet eens meer op het forum te stellen.
Bedankt !

Rob

 

[edmoor]

Graag gedaan