Melding voorzien indien LKxxx niet in lijst voorkomt

[HSV]

Helaas kan ik het niet rechtstreeks opslaan vanuit Google Chrome, wel openen.

Helaas geeft je .xlsb bestand dezelfde melding dat het bestand is beschadigd.

 

[danny147]

Beste HSV,

En zo

http://www.filedropper.com/planningdanny

Grts Danny147

 

[HSV]

Zo lukt het wel Danny.

Kijk eens naar de gedefinieerde namen 'IBNStart en IBNEinde'.
Daar zit je fout.

 

[danny147]

Beste HSV,

Ik zie er niks verkeerd aan, waar ligt de fout ?
Je moet eerst de rijen 25 tem 147 verwijderen en daarna terug alles opladen

IBNStart zal dan rij 47 zijn en IBNEinde rij 61, daar waar sjabloon IBN staat

Telkens als het bestandje geopend wordt worden de tellers allemaal op nul geplaatst.

Grts Danny147

 

[HSV]

Ik zat verkeerd.
Het stuk van 'IBN' wil je er niet in hebben staan toch.
Dan moet dat stukje verwijderd worden uit de code?

gedef: IBN =Systeem!$E$69:$V$82

 

[danny147]

Beste HSV,

Jawel, dit staat onder LK100 zie afbeelding.

.Range("IBN").Copy Sheets(mySheetName).Range("A" & iRowStart)

Alles is goed zoals het nu is buiten hetgeen ik gevraagd heb hoe het resultaat moet zijn of zie post #110

Grts Danny147

 

[HSV]

Ik zie nu weer ineens dat je die rijen gegroepeerd hebt.
Wat mankeert er dan nog aan?
Alleen "Storingen en ander werken"?

 

[danny147]

Beste HSV,

Storingen en andere werken is OK

Als je het bestandje opent dan zou je gezien hebben hetgeen opgeladen is van Output danny en daaronder hetgeen ik wil.
Nu wordt alles dubbel onder elkaar geschreven en dat wil ik vermijden.

Als er 1 persoon op het werk staat moet er 1 regel geschreven worden en staan er 8 personen op, dan wordt de regel 8x geschreven zodat ik hier 8 personen via de gegevenslijst kan toevoegen.

Is er ook een mogelijkheid om het driehoekje en het rondje te kleuren als kolom 8 RE of RM is
Via voorwaardelijke opmaak moet ik dit handmatig doen en met code gaat dit sneller.

Had gedacht aan dit stukje code:

        x = iRowStart - 1
        last = iRowEinde - iRowStart + 1
    For x2 = 1 To last
        if left("H"  & x + x2, 2) = "RM" then

    With Selection.Font
        .Color = -4165632 'voor RE .Color = -13321973

    End With

    End If

    Next x2

Kan je dit voor elkaar krijgen want zo werkt het niet

Grts DannY147

 

[HSV]

Ik mag een boon worden als je schrijft dat alles wat dubbel is wilt vermijden.
Terwijl in het bestand dat je stuurt er bij "Zo moet het resultaat zijn" alles dubbel staat.

We zitten niet echt op één lijn zo.

 

[HSV]

Verander dit stuk eens Danny.

.AutoFilter 5, arr(0), 2, arr(1)
         .AutoFilter 6, Blad10.Cells(str, 4) & "*"
                sn = .Cells(1).CurrentRegion
                     ReDim arr2(1 To UBound(sn), 1 To UBound(sn, 2))
                       For ii = 2 To UBound(sn)
                        If Not .Rows(ii).Hidden Then
                           
                      For jj = 1 To sn(ii, 13)
                       n = n + 1
                         For j = 1 To UBound(sn, 2)
                            arr2(n, 1) = sn(ii, 3)
                            arr2(n, 2) = sn(ii, 9)
                            arr2(n, 3) = sn(ii, 10)
                            arr2(n, 8) = sn(ii, 5)
                            arr2(n, 9) = sn(ii, 13)
                            c00 = Application.index(sn, 1, 0)
                            c01 = Replace(Format(twb.Cells(1, 3), "dd-mm-yyyy"), "-", ".")
                            c02 = Application.Match(c01, c00, 0)
                            If Not IsError(c02) Then arr2(n, 10) = sn(ii, c02)
                            arr2(n, 11) = sn(ii, 2)
                            arr2(n, 13) = sn(ii, 8)
                            arr2(n, 15) = IIf(arr2(n, 8) = "RE-1", ThisWorkbook.Sheets("systeem").Cells(1, 1).Value, ThisWorkbook.Sheets("systeem").Cells(2, 1).Value)
                        Next j
                     ' n = n + 1
                     Next jj
                    End If
                  
                  Next ii
                'twb.Range("A" & iRowStart + 1).Resize(n, 15) = arr2
                twb.Range("A1000").End(xlUp).Offset(1).Resize(n, 15) = arr2


                n = 0
                Erase arr2

 

[danny147]

Beste HSV,

Knap staaltje vakwerk :thumb:

Kan je het stukje code dat ik voorzien had wat aanpassen zodat dit werkt voor de driehoekjes en rondjes te kleuren.
Alsook voor de gegevenslijst.

Grts Danny147

 

[HSV]

Gelieve de cellen te benoemen Danny anders moet ik steeds gokken.

 

[danny147]

Beste HSV,

Voor de groene driehoekjes en blauwe rondjes:

De te zoeken kolom is H, de plaats waar de kleuren moeten komen is O.
De rijen zijn variabel maar begint met " iRowStart"
Het einde is "iRowEinde"

Voor de gevensvalidatie:

De te zoeken kolom is H, de plaats waar de gegevensvalidatie moet komen is P
De rijen zijn variabel maar begint met " iRowStart"
Het einde is "iRowEinde"
In te geven gegevens zijn:
Is kolom H --> RE-1 dan is gegevensvalidatie =RE_1
Is kolom H --> RE-2 dan is gegevensvalidatie =RE_2
Is kolom H --> RE-DG dan is gegevensvalidatie =RE_DG
Is kolom H --> RM-1 dan is gegevensvalidatie =RM_1
Is kolom H --> RM-2 dan is gegevensvalidatie =RM_2
Is kolom H --> RM-DG dan is gegevensvalidatie =RM_DG

Je zal dit waarschijnlijk niet kunnen testen, daarom zal ik dit wel doen bij het uitvoeren van de gegevens.
Omdat iRowStart en iRowEinde geen waarden hebben in tabbald Systeen, deze worden telkens gewist bij openen van bestandje.

Grts Danny147

 

[Ginger]

Mag ik zo vrij zijn om héél even in te breken op deze draad (want van een "draadje" kan je niet meer spreken) voor een heel klein regeltje commentaar? Ik wil héél graag mijn complimenten uitspreken voor het geduld en de inzet van HSV. Deze is voor wat mij betreft van ongekende hoogte.

Hulde hulde hulde !!! :thumb: :thumb: :thumb:


p.s. En normaal zou ik best wel nog wat willen helpen, maar dat durf ik in deze vraag écht niet aan...

 

[danny147]

Beste Ginger,

Ik apprecieer je inbreng :thumb:

HSV heeft alle tijd wat mij betreft en af en toe een complimentje kan geen kwaad hé

Knap staaltje vakwerk :thumb:

Jammer dat ik niet in staat ben zo diep in VBA mee te kunnen, het wordt tijd dat ik wat lessen volg


Grts Danny147

 

[HSV]

Hallo Danny en Leo,

Leo, bedankt voor de mooie woorden (waardeer ik enorm). :thumb:
Wat kan ik anders, het draadje is zo omvangrijk geworden dat er niemand meer instapt en we te ver zijn om te stoppen.
Dat kan ik Danny niet meer aan doen, maar er moet wel een keer een einde aan komen.

Danny,
Voor jou lijkt het of het uren heeft even geduurd om tot een oplossing te komen, maar ik ben in slaap gevallen. :d

Daarna moest ik er achter zien te komen welke waarde de ► of de ☻ vertegenwoordigde (het lukte niet met de gewone 'Asc(cl)' ).
Dus de Help van Vba erbij wat ik nog meer voor mogelijkheden had.
Het lijkt me gelukt te zijn met de functie 'AscW', en daarna weer de kleurtjes opzoeken die daarbij horen.

Dit is de code vervolg() die volgens niet van mij is , maar dit terzijde.
Ik heb het blauwe gedeelte erin geplaatst.

Nog geen validatie toegepast totdat ik weet of dit werkt.

Sub vervolg()
    mySheetName = ActiveSheet.Name


    With ThisWorkbook.Sheets("Systeem")


        .Range("CHEinde").Value = Sheets(mySheetName).Range("A1000").End(xlUp).row


        iRowEinde = .Range("CHEinde")
        iRowStart = .Range("CHStart")


    With ThisWorkbook.Sheets(mySheetName)


        .Rows(iRowStart + 1 & ":" & iRowEinde).Rows.Group
        


[COLOR=#3366ff]     For Each cl In [/COLOR][COLOR=#3366cc].Range("O" & iRowStart, "O" & iRowEinde)[/COLOR]
[COLOR=#3366ff]      If cl <> "" Then[/COLOR]
[COLOR=#3366ff]        Select Case AscW(cl)[/COLOR]
[COLOR=#3366ff]          Case 9658[/COLOR]
[COLOR=#3366ff]            cl.Font.ColorIndex = 4[/COLOR]
[COLOR=#3366ff]          Case 9787[/COLOR]
[COLOR=#3366ff]            cl.Font.ColorIndex = 23[/COLOR]
[COLOR=#3366ff]        End Select[/COLOR]
[COLOR=#3366ff]      End If[/COLOR]
[COLOR=#3366ff]     Next cl[/COLOR]


    With ThisWorkbook.Sheets("Systeem")
    
       .Range("CHBTRStart").Value = .Range("CHEinde") + 2
       
        iRowStart = .Range("CHBTRStart")
        
        .Range("ColumnHeaderBTR").Copy Sheets(mySheetName).Range("A" & iRowStart)




'        Hieronder vult men weer gegevens in via volgend bestandje op tabblad 2, locatie is:
'        ChDir "\\Sidmar.be\dfs\Dienst\GROEP\LAD\LPK\Betacel\Projecten"
'        Workbooks.Open Filename:="file:\\Sidmar.be\dfs\Dienst\GROEP\LAD\LPK\Betacel\Projecten\planningEXT.xlsx", ReadOnly:=True
'        Eerst kijkt men naar de datum, dan naar LKXXX en men schrijft de gegevens weg op de juiste plaats.
'        Indien er geen gegevens aanwezig zijn dan melding: "Geen gegevens aanwezig voor Betrouwbaarheidscel" en code verder laten lopen


        .Range("CHBTREinde").Value = Sheets(mySheetName).Range("A1000").End(xlUp).row + 2


        iRowEinde = .Range("CHBTREinde").Value


        
    With ThisWorkbook.Sheets(mySheetName)
    
        .Rows(iRowStart + 1 & ":" & iRowEinde).Rows.Group
        
    With ThisWorkbook.Sheets("Systeem")
    
        .Range("CHBGEStart") = .Range("CHBTREinde").Value + 2
        iRowStart = .Range("CHBGEStart")
    
        .Range("ColumnHeaderBGE").Copy Sheets(mySheetName).Range("A" & iRowStart)


'        Hieronder vult men weer gegevens in via volgend bestandje op tabblad 2, locatie is:
'        ChDir "\\Sidmar.be\dfs\ORGANISATIE\LAD\GROEP\LPK\Planning\Systeem"
'        Workbooks.Open Filename:="file:\\sidmar.be\dfs\Dienst\GROEP\LAD\LPK\Planning\Systeem\Externen.xlsx", ReadOnly:=True
'        Eerst kijkt men naar de datum, dan naar LKXXX en men schrijft de gegevens weg op de juiste plaats.
'        Indien er geen gegevens aanwezig zijn dan melding dat er "geen gegevens aanwezig voor Externen"en code verder laten lopen


        .Range("CHBGEEinde").Value = Sheets(mySheetName).Range("A1000").End(xlUp).row + 2


        iRowEinde = .Range("CHBGEEinde")


        Rows(iRowStart + 1 & ":" & iRowEinde).Rows.Group
        
        iRowStart = .Range("IBNStart")
        
        Rows(iRowStart - 1 & ":" & iRowEinde + 1).Rows.Group


        Range("A" & iRowStart + 4).Select
  End With
    End With
      End With
        End With
         End With
        Application.ScreenUpdating = True
End Sub

 

[danny147]

Beste HSV,

Het werkt als een liertje :thumb:

Het einde is in zicht, nog 2 onderwerpen

Nu nog de validatie en dan nog 1 gegeven ophalen uit een ander bestandje.

Grts Danny.

 

[HSV]

Beste HSV,

Het werkt als een liertje :thumb:
Grts Danny.

Om in vakterm te blijven? :d :d

Vervang het blauwe gedeelte in mijn vorige post door onderstaand.

For Each cl In .Range("H" & iRowStart, "H" & iRowEinde)
      If cl <> "" Then
       Select Case cl
          Case Split(mySheetName, "_")(0)
            cl.Offset(, 7).Font.ColorIndex = 23
            cl.Offset(, 8).Validation.Delete
            cl.Offset(, 8).Validation.Add 3, 1, , "=" & Replace(cl, "-", "_")
          Case Split(mySheetName, "_")(1)
            cl.Offset(, 7).Font.ColorIndex = 4
            cl.Offset(, 8).Validation.Delete
            cl.Offset(, 8).Validation.Add 3, 1, , "=" & Replace(cl, "-", "_")
        End Select
      End If
     Next cl

Of de iets kortere versie.

For Each cl In .Range("H" & iRowStart, "H" & iRowEinde)
     If cl <> "" Then
        cl.Offset(, 8).Validation.Delete
        cl.Offset(, 8).Validation.Add 3, 1, , "=" & Replace(cl, "-", "_")
        cl.Offset(, 7).Font.ColorIndex = IIf(cl = Split(mySheetName, "_")(0), 23, 4)
     End If
 Next cl

 

[snb]

of

For Each cl In .Range("H" & iRowStart, "H" & iRowEinde)
  If cl <> "" Then
    cl.Offset(, 8).Validation.modify 3, 1, , "=" & Replace(cl, "-", "_")
    cl.Offset(, 7).Font.ColorIndex = IIf(cl = Split(mySheetName, "_")(0), 23, 4)
  End If
Next

 

[HSV]

@snb, 'Modify' past een validatielijst aan, maar volgens mij zijn de cellen leeg.
Vandaar eerst maar 'delete' en daarna 'Add' toegepast.

Anders mag de regel 'delete' eruit.