10 datums toevoegen aan een kolom met unieke codes

[Backer78]

Hoi,

Ik heb in kolom A een lijst met unieke codes (deze lijst is in werkelijkheid veel langer).
Achter iedere code wil ik in kolom B, 10 datums toevoegen (zie kolom C voor de datums in de bijlage)

Uiteindelijk wil ik uitkomen op het voorbeeld zoals in de bijlage vanaf regel 14.
Ik heb via chatgpt al heel wat formules geprobeerd, maar deze lijken allemaal niet te werken (of ik doe natuurlijk iets verkeerd).

Hoop dat iemand me hierbij helpen kan.

Groet,

Melissa

 

[snb]

Ik zie geen bijlage.

 

[Backer78]

excuses dom van mij

 

[don42]

Bedoel je zoiets?

 

[snb]

mijn voorstel

 

[emields]

of met een macro

 

[Verwijderd lid 501906]

deze VBA houd rekening met de lengte van het aantal codes
en zet daarachter de lijst met data

 

[Backer78]

Hel erg bedankt voor de snelle reactie, ik ben een leek in excel en begrijp dus niet alles wat jullie schrijven.
Het bestand van SNB doet precies wat ik zoek, maar hoe zorg ik er voor dat er tussenruimte tussen de code komt (A14 tm A23) voordat hij de datums weer neerzet bij de volgende code. (P.S.: de datums blijven altijd 22-12-27 t/m 31-12-2027)

 

[Verwijderd lid 501906]

kijk hier eens naar
druk op de knop
lijst met code kun je uitbreiden

 

[Backer78]

DIt is precies wat ik zocht! super bedankt

 

[Verwijderd lid 501906]

Is je vraag opgelost markeer ze dan ook als Opgelost!

Deze VBA werkt zolang de datum lijst gelijk of korter is dan de code lijst.
Het script is makkelijk aan te passen als je een ander gebied wilt gebruiken

alleen deze 2 regels aanpassen
' Definieer de ranges voor de "code" en "datums" lijsten
' Set rngCodes = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
' Set rngDatums = ws.Range("C2:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)

 

[AlexCEL]

Deze Excel 365 formule geeft exact je gevraagde output (dus incl. lege kolom ertussen).

=LET(a;A2:A11;c;C2:C11;
g;AANTALARG(a);h;AANTALARG(c);y;REEKS(g*h);
z;1+(y-1)/h;
q;ALS(REST(z;1)=0;INDEX(a;z);"");
r;MAKEARRAY(g*h;1;LAMBDA(v;w;""));
s;INDEX(c;1+REST(y-1;h));
HOR.STAPELEN(q;r;s))

Je kan lijsten inkorten, dat gaat ook prima. Om de lege kolom weg te laten haal je parameter r weg.

 

[Warme bakkertje]

Deze werkt ongeacht de lengte van beide lijsten.

Sub tst()
Dim Codes, Datums, sq
Dim ddd As Long, i As Long, j As Long
With Sheets("Sheet1")
    Codes = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    Datums = .Range("C2", .Range("C" & .Rows.Count).End(xlUp))
    ddd = (UBound(Codes) * UBound(Datums)) + UBound(Codes)
    ReDim sq(1 To ddd, 1 To 3): x = 1
    For i = 1 To UBound(Codes)
        sq(x, 1) = Codes(i, 1)
        For j = 1 To UBound(Datums)
            sq(x, 3) = Datums(j, 1): x = x + 1
        Next
        x = x + 1
    Next
    .Cells(15, 1).Resize(UBound(sq), 3) = sq
End With
End Sub

 

[emields]

Nu we toch bezig zijn, alle variabelen vrij te kiezen

 

[snb]

@ruben

Vermijd overbodige objectvariabelen.
Vermijd interaktie met het werkblad.
Voer berekeningen uit in het werkgeheugen.

Sub M_snb()
    sn = Cells(1).CurrentRegion
    sq = Cells(2, 3).CurrentRegion
    ReDim sp(UBound(sn) * UBound(sq), 1)
   
    For j = 0 To UBound(sp)
      If j Mod (UBound(sq) + 1) < UBound(sq) Then
         sp(j, 0) = sn(j \ (UBound(sq) + 1) + 2, 1)
         sp(j, 1) = sq(j Mod (UBound(sq) + 1) + 1, 1)
      End If
    Next
   
    Cells(1, 6).Resize(UBound(sp)+1, 2) = sp
End Sub

 

[Verwijderd lid 501906]

@snb
zeer cool dit is jou output


en volgens mij vraagt ze dit


Daarbij komt dat ze het onder de codelijst wilde hebben

 

[snb]

presenteerblaadje ?

Sub M_snb()
    sn = Cells(1).CurrentRegion
    sq = Cells(2, 3).CurrentRegion
    ReDim sp(UBound(sn) * UBound(sq), 1)
    
    For j = 0 To UBound(sp)
      If j Mod (UBound(sq) + 1) = 0 Then sp(j, 0) = sn(j \ (UBound(sq) + 1) + 2, 1)
      If j Mod (UBound(sq) + 1) < UBound(sq) Then sp(j, 1) = sq(j Mod (UBound(sq) + 1) + 1, 1)
    Next
    
    Cells(1, 6).Resize(UBound(sp) + 1, 2) = sp
End Sub

 

[Verwijderd lid 501906]

Als ik een code lijst maak tot "code 18"
en datum terug breng tot 4 stuks

dan is dit het einde code 16
En deze is dan maar half af
17 en 18 ontbreken geheel
ga eens wat meer spelen met de het script.
er gaat nog meer fout.

​

 

[snb]

Je geeft wat weinig aanwijzingen.
zorg dat cel A1 begint met de eerste reeks en cel C1 met de tweede.

Sub M_snb()
    sn = Cells(1).CurrentRegion
    sq = Cells(1, 3).CurrentRegion
    y = (UBound(sq) + 1)
    ReDim sp(UBound(sn) * y, 1)
    
    For j = 0 To UBound(sp) - 1
      If j Mod y = 0 Then sp(j, 0) = sn(j \ y + 1, 1)
      If j Mod y < UBound(sq) Then sp(j, 1) = sq(j Mod y + 1, 1)
    Next
    
    Cells(1, 6).Resize(UBound(sp) + 1, 2) = sp
End Sub

 

[Verwijderd lid 501906]

Ik heb maar even 2 voorbeelden met jou script gedaan
En rekening gehouden met extra opgelegde voorwaarden

zorg dat cel A1 begint met de eerste reeks en cel C1 met de tweede.

kijk naar het einde
Het klopt gewoon niet.

Bij mijn script staat het onder de code lijst
zoals de vragensteller vroeg en hoef je alleen op de knop te drukken.
Om geen extra verwarring te scheppen heb ik mijn script weggelaten.