Bestand uitbreiden

[MEradus]

Goedemorgen allen,

Dankzij een aantal van jullie heb heb ik het voorbeeld bestand kunnen maken en zelf kunnen uitbreiden.
Hier ben ik erg blij mee, want dit scheelt mij ontzettend veel werk.

Nu klik ik op de knop "Klik hier om daglijst te maken" en dan wordt alleen de datum die dus in cell Q2 staat ingevoerd.

Maar ik zou heel graag voor sommige roosters i.p.v. een daglijst een week of een zelfs een maandlijst kunnen maken.
Maar op een of andere manier krijg ik dit niet voor elkaar om het bestand naar een datum range te zoeken ipv 1 datum zoals het nu staat.


Is er iemand die mij hier mee kan helpen?

Alvast bedankt voor het meedenken.

 

[OctaFish]

Als we even voorbij gaan aan het feit dat je code een heel stuk korter kan (er zitten nogal wat overbodige doublures in), is je vraag niet duidelijk. Om te beginnen: hoe wil je bepalen of je een weekrooster of een maandrooster gaat maken?

 

[MEradus]

Ik zou dit het liefst willen bepalen door een datum range in te voeren. (Dus bijvoorbeeld "Q2" de 1e datum en dan in "R2" de tweede datum. En alles daar tussen in).
Zodat ik naar aanleiding daarvan kan bepalen of het 1 week, 2 weken of een maand moet zijn.
Sorry als ik daarin wat onduidelijk was.

O ja, en als een datum leeg blijkt te zijn en de volgende datum niet, moet hij wel doorgaan, maar hoeft de lege datum niet ingevoerd te worden.

 

[OctaFish]

Dus of je een reeks invoert of voor één dag is alleen afhankelijk van het wel of niet invoeren van een tweede datum in R2? Want dan praat je dus niet over een weekrooster of een maandrooster...

 

[MEradus]

Zo zou je het kunnen zien, het komt er op neer dat ik graag een datum bereik wil kunnen invoeren.
Misschien is dat beter dan praten over een week of maand rooster, toch?

 

[OctaFish]

Lijkt mij wel . Ik zal eens kijken wat ik er van kan brouwen.

 

[MEradus]

Top, dank je wel alvast!

 

[VenA]

Van chaos naar chaos kost nogal veel code. Probeer het maar eens.

Sub VenA()
  ar = Sheets("Rooster").Cells(3, 1).CurrentRegion.Resize(Sheets("Rooster").Cells(Rows.Count, 1).End(xlUp).Row - 2)
  ar1 = Sheets("Lijst").Cells(1).CurrentRegion
  ar2 = Split("ZOP ZOP1 AOP2 DOP DOP1 07:30-17:59 08:00-17:00 12:00-21:59 08:00-16:00 07:00-19:00")
  ReDim ar3(11, 0)
  b = Cells(2, 17)
  e = IIf(Cells(2, 18) = "", b, Cells(2, 18))
  For j = 2 To UBound(ar)
    If ar(j, 1) >= b And ar(j, 1) <= e Then
      For jj = 3 To UBound(ar, 2)
        If ar(j, jj) <> "" Then
          x = ar2(Application.Match(ar(j, jj), ar2, 0) + 5)
          y = Application.Match(ar(1, jj), Sheets("Lijst").Columns(1), 0)
          ar3(0, t) = ar1(y, 2)
          ar3(1, t) = ""
          ar3(2, t) = ""
          ar3(3, t) = Split(x, "-")(0)
          ar3(4, t) = Split(x, "-")(1)
          ar3(5, t) = ""
          ar3(6, t) = ""
          ar3(7, t) = ""
          ar3(8, t) = ""
          ar3(9, t) = ar1(y, 3)
          ar3(10, t) = ar(1, jj)
          ar3(11, t) = Format(ar(j, 1), "mm-dd-yyyy")
          t = t + 1
          ReDim Preserve ar3(11, t)
        End If
      Next jj
    End If
  Next j
  Cells(1).CurrentRegion.Resize(, 12).Offset(1).ClearContents
  If t > 0 Then Cells(2, 1).Resize(t, 12) = Application.Transpose(ar3)
End Sub

 

[snb]

Lijkt me een typisch geval voor een draaitabel.

 

[MEradus]

@VenR,

Jouw code werk voor dit bestand precies zoals ik hem bedoelde.
Het is alleen dat ik hem heb proberen aan te passen naar een van mijn andere bestanden met wat meer diensten en meer mensen krijg ik een foutmelding. "Fout 9 tijdens uitvoering, Het subscript val buiten bereik".
Hij stopt bij (onderstaande) rode tekst.
Ik kom er alleen niet achter waar deze fout vandaag komt. Heb je misschien een tip voor mij waar ik de fout zou kunnen vinden?
Waarschijnlijk is alleen extra diensten toevoegen niet voldoende

Sub VenA()
  ar = Sheets("Rooster").Cells(3, 1).CurrentRegion.Resize(Sheets("Rooster").Cells(Rows.Count, 1).End(xlUp).Row - 2)
  ar1 = Sheets("Lijst").Cells(1).CurrentRegion
  ar2 = Split("TD1 TD2 TDS TDM TDAM TD4 TLm TL1 TDW1 TDW2 TDW3 TLW1 TLW2 TTL 07:00-17:00 07:30-16:30 07:30-14:00 08:30-14:00 08:30-17:00 08:00-17:00 10:00-19:00 14:00-21:00 14:00-20:30 07:30-15:00 09:00-18:00 10:00-18:00 15:00-22:00 17:00-22:00 16:00-22:00")
  ReDim ar3(11, 0)
  b = Cells(2, 17)
  e = IIf(Cells(2, 18) = "", b, Cells(2, 18))
  For j = 2 To UBound(ar)
    If ar(j, 1) >= b And ar(j, 1) <= e Then
      For jj = 3 To UBound(ar, 2)
        If ar(j, jj) <> "" Then
          x = ar2(Application.Match(ar(j, jj), ar2, 0) + 5)
          y = Application.Match(ar(1, jj), Sheets("Lijst").Columns(1), 0)
          ar3(0, t) = ar1(y, 2)
          ar3(1, t) = ""
          ar3(2, t) = ""
          ar3(3, t) = Split(x, "-")(0)
[COLOR="#FF0000"]          ar3(4, t) = Split(x, "-")(1)[/COLOR]
          ar3(5, t) = ""
          ar3(6, t) = ""
          ar3(7, t) = ""
          ar3(8, t) = ""
          ar3(9, t) = ar1(y, 3)
          ar3(10, t) = ar(1, jj)
          ar3(11, t) = Format(ar(j, 1), "mm-dd-yyyy")
          t = t + 1
          ReDim Preserve ar3(11, t)
        End If
      Next jj
    End If
  Next j
  Cells(1).CurrentRegion.Resize(, 12).Offset(1).ClearContents
  If t > 0 Then Cells(2, 1).Resize(t, 12) = Application.Transpose(ar3)
End Sub

@Snb: Helaas red ik het niet met een draaitabel, met de code die ik nu hem en graag uit wil breiden, wordt het bestand een inlees bestand. Deze moet er dus uitzien zoals het in het tabblad "Week-Maandlijst maken" Anders werkt het niet zoals het hoort te werken.

 

[VenA]

Je kan toch zien welke waarde x krijgt? Dan weet je ook waar het fout gaat.

Als ik goed geteld heb

x = ar2(Application.Match(ar(j, jj), ar2, 0) +[COLOR=#FF0000] 14[/COLOR])

 

[MEradus]

Klopt, deze kreeg inderdaad een waarde (een van de dienstnamen (TLm).
Alleen kon ik niet plaatsten waar hij deze weghaalde.

Met de regel die jij laat zien snap ik in ieder geval dat ik dit bij de dienstnaam en tijden moet zoeken.
Maar op een of andere manier blijf ik een foutmelding krijgen.

Kan het zijn dat als er waardes instaan die niet in deze lijst staan:

ar2 = Split("TD1 TD2 TDS TDM TDAM TD4 TLm TL1 TDW1 TDW2 TDW3 TLW1 TLW2 TTL 07:00-17:00 07:30-16:30 07:30-14:00 08:30-14:00 08:30-17:00 08:00-17:00 10:00-19:00 14:00-21:00 14:00-20:30 07:30-15:00 09:00-18:00 10:00-18:00 15:00-22:00 17:00-22:00 16:00-22:00")

hij daarop fout gaat?

Ik heb geprobeerd om de deze waarden erbij te zetten en dan krijg ik dezelfde foutmelding.
Ik zal eens even kijken wat ik nog meer over het hoofd kan zien. (Gaat wel wat langer duren, want ben en blijf een leek).

 

[VenA]

Loop met <F8> door de code en kijk wanneer het fout gaat welk variabele welke waarde heeft.

 

[MEradus]

Hoi VenA,

Het zal wel aan mij liggen, maar ik kan het euvel niet vinden.
Laten we het er maar op houden dat dit aan mijn "leek" zijn ligt

Heb verschillende manieren geprobeerd, maar ik val van de ene foutmelding in de andere.

Ik zet het bestand waar het om gaat, bij deze krijg ik nu "Typen komen niet overeen". Terwijl deze wel in het lijstje staat....
Misschien dat je mij kunt vertellen wat ik over het hoofd zie?

Ik heb namelijk nog een aantal van dit soort bestanden die nog 'groter' zijn qua mensen en diensten.
Dus wil het heel graag begrijpen zodat ik het zelf kan.

Hopelijk wil je mij hier mee helpen.

 

[HSV]

Een paar fouten in je bestand.

Cel

C3:P3

in blad 'rooster' zijn niet identiek aan blad Lijst kolom A.
Kolom A van blad 'Lijst' bevat ook overtollige spaties.

Op te lossen door

 C3:P3

te kopiëren en plakken speciaal → waarden en transponeren naar blad 'Lijst' A1.

Maak van 17 een 16.

x = ar2(Application.Match(ar(j, jj), ar2, 0) + [COLOR=#ff0000]17[/COLOR])

Maak van 1 een 2 in...

y = Application.Match[COLOR=#ff0000](ar(1, jj)[/COLOR], Sheets("Lijst").Columns(1), 0)

Van ubound(ar,2) heb ik maar 16 gemaakt verder hoeft volgens mij niet.

Zo ziet het er dan uit.

For jj = 3 To [COLOR=#ff0000]16 'UBound(ar, 2)[/COLOR]
[COLOR=#ff0000]        If Not IsNumeric(ar(j, jj)) Then[/COLOR]
        
          x = ar2(Application.Match(ar(j, jj), ar2, 0) + 16)
          y = Application.Match(ar(2, jj), Sheets("Lijst").Columns(1), 0)

Naar het resultaat heb ik niet gekeken, dat mag jezelf controleren.

 

[VenA]

Hoe wil je dit gaan toepassen op andere bestanden als je niet begrijpt wat er zoal fout gaat? Volgens mij zijn de meeste punten al aangestipt door @HSV
-Het bereik is veranderd;
-Er staan codes in de zwarte cellen die niet voorkomen in ar2 (bv een 1 in D18);
-Van de namen in de tab lijst klopt niet veel.

Dit zijn allemaal zaken die je bij het debuggen tegenkomt.

Om dit soort slordigheden te ondervangen zal de code weer wat langer worden. Een iets andere benadering dan de suggesties van @HSV hoewel ze op hetzelfde neerkomen.

Sub VenA()
  [COLOR="#FF0000"]ar = Sheets("Rooster").Cells(3, 1).Resize(Sheets("Rooster").Cells(Rows.Count, 1).End(xlUp).Row - 2, 16)[/COLOR]
  ar1 = Sheets("Lijst").Cells(1).CurrentRegion
  ar2 = Split("TD1 TD2 TDS TD3 TDM TDAM TD4 TLm TL1 TDW1 TDW2 TDW3 TLW1 TLW2 TTL plan V 07:00-17:00 07:30-16:30 07:00-14:00 08:00-17:00 08:30-14:00 08:30-17:00 10:00-19:00 14:00-21:00 14:00-20:30 07:30-15:00 09:00-18:00 10:00-18:00 15:00-22:00 17:00-22:00 16:00-22:00 00:00-00:00 00:00-00:00")
  ReDim ar3(11, 0)
  b = Cells(2, 17)
  e = IIf(Cells(2, 18) = "", b, Cells(2, 18))
  For j = 2 To UBound(ar)
    If ar(j, 1) >= b And ar(j, 1) <= e Then
      For jj = 3 To UBound(ar, 2)
        If ar(j, jj) <> "" Then
          [COLOR="#FF0000"]Z = Application.Match(ar(j, jj), ar2, 0)[/COLOR]
          y = Application.Match(ar(1, jj), Sheets("Lijst").Columns(1), 0)
          [COLOR="#FF0000"]If IsNumeric(Z) And IsNumeric(y) Then[/COLOR]
            [COLOR="#FF0000"]x = ar2(Z + 16)[/COLOR]
            ar3(0, t) = ar1(y, 2)
            ar3(1, t) = ""
            ar3(2, t) = ""
            ar3(3, t) = Split(x, "-")(0)
            ar3(4, t) = Split(x, "-")(1)
            ar3(5, t) = ""
            ar3(6, t) = ""
            ar3(7, t) = ""
            ar3(8, t) = ""
            ar3(9, t) = ar1(y, 3)
            ar3(10, t) = ar(1, jj)
            ar3(11, t) = Format(ar(j, 1), "mm-dd-yyyy")
            t = t + 1
            ReDim Preserve ar3(11, t)
          End If
        End If
      Next jj
    End If
  Next j
  Cells(1).CurrentRegion.Resize(, 12).Offset(1).ClearContents
  If t > 0 Then Cells(2, 1).Resize(t, 12) = Application.Transpose(ar3)
End Sub

 

[MEradus]

Goedemorgen HSV en VenA,

Dank jullie wel voor jullie uitleg.
Vooral het feit dat er fouten in het bestand stonden is natuurlijk een beetje dom want dat had ik eerst moeten ondervangen.

Ik heb nu de namen in de tab "Lijst" allemaal hetzelfde gemaakt, codes of iets dergelijks in cellen die leeg horen te zijn heb ik eruit gehaald en heb het bereik aangepast.
Het werkt nu super! Ook begin ik een beetje door te hebben hoe de code is opgebouwd. En dat is voor mij al best wel wat!

Super bedankt voor jullie hulp! Ik ga deze vraag op opgelost zetten!

 

[MEradus]

Bijna

Goedemorgen,

In mijn vorige bericht had ik aangegeven dat de vraag opgelost was, maar ik kwam erachter dat er nog een stukje mist.
Als ik hier een nieuwe topic voor moet maken hoor ik het graag.

In bijgevoegd voorbeeld bestand in het tabblad rooster, staat de 1e code waarmee ik een daglijst maakte.
Aan het einde van de code stond nog een stukje code (

  For Each it In Blad1.Rows(Rij).SpecialCells(-4144)
  Blad2.Columns(11).Find(Blad1.Cells(3, it.Column)).Offset(, 3) = it.Comment.Text

welke ervoor zorgde dat de opmerking/notie in het hetzelfde blad achter de juiste medewerker kwam te staan.

Doordat VenA een kortere code heeft gemaakt en samen met HVS mij geholpen hebben werkt de code super.
Alleen werkt deze code zodat de opmerkingen/notities er bij kwam te staan, niet meer.

Door op "Klik hier om daglijst te maken" zie je wat de bedoeling is. Ik hoop dat dit ook mogelijk is om dit in een periode lijst te doen.

Alvast bedankt voor het meedenken.

 

[VenA]

Zelf maar een beetje puzelen wat je nog meer moet aanpassen.

If Not Sheets("Rooster").Cells(j + 2, jj).Comment Is Nothing Then ar3(12, t) = Sheets("Rooster").Cells(j + 2, jj).Comment.Text

 

[MEradus]

Hoi VenA,

Dank je wel voor de code,

En ook bedankt dat je mij even hebt laten zweten om de code werkend te krijgen.
Ik heb bij een aantal plaatsen de range aangepast.
Waardoor de code nu prima werkt!

Bij deze is de vraag opgelost!

Nogmaals bedankt!