5 rijen toevoegen aan elke waarde uit kolom A + kolom b vullen

[1965Peter]

Hallo,

Ik ben bezig met een mappenstructuur, waarvan kolom A Klantnamen bevat. (ca.1500).
Nu moet er van elke klant, 5 rijen worden toegevoegd, en in kolom B, 5 submappen worden toegevoegd.
Zie voorbeeld bestand

 

[LucHeyndrickx]

Je moet je bestand opslaan als een bestand met macro's.
Vervolgens deze macro opslaan:

Sub VoegToe()
    Dim i As Integer
    Dim y As Integer
    Dim col As Collection
    
    Set col = New Collection
    col.Add "Contracten"
    col.Add "Verlenging & Aanpassing & Beëindigen"
    col.Add "Facturatie"
    col.Add "Overzichten"
    col.Add "Ordernummers(PO)"
    col.Add "Overige"
    y = 1
    With Sheets("Blad1")
        Do Until .Cells(y, 1).Value = ""
            .Cells(((y - 1) * 5) + 1, 3).Value = .Cells(y, 1).Value
            For i = 1 To 5
                .Cells(((y - 1) * 5) + i, 4).Value = col(i)
            Next
            y = y + 1
        Loop
    End With
End Sub

En uitvoeren. Ik heb je lijst in kolom C en D gezet. Uiteraard zal je nog het een en ander moeten aanpassen, maar aan je bestand te zien, kan dat toch niet het totale bestand zijn, maar slechts een eenvoudige voorstelling ervan. (Waarvoor dank, want je vraag kan je natuurlijk beter beperken tot de essentie.)
Verander de locatie niet naar de A en B kolom, vermits je dan de brongegevens gaat overschrijven, en dan loopt het uiteraard fout.
Je zou het eventueel naar een ander werkblad kunnen verplaatsen, of eerst enkele extra kolommen toevoegen, om ze vervolgens terug te verwijderen. Enfin... beetje extra creativiteit dus.

 

[1965Peter]

Hallo LucHeyndrickx,

Dit is precies wat ik wilde, in kolom C & D is helemaal prima.
Heel erg bedankt voor de moeite.
:thumb:

 

[HSV]

Andere methode.

Sub hsv()
Dim sv, sq
  sq = Cells(1).CurrentRegion.Columns(1)
  sv = Split(Join(Evaluate("transpose(a1:a" & UBound(sq) & ")"), String(6, vbCr)), vbCr)
  Cells(1, 2).Resize(UBound(sv) + 1) = Application.Transpose(sv)
  Cells(1, 3).Resize(UBound(sv) + 6) = Application.Transpose(Split(Replace(String(UBound(sq), "|"), "|", Join([transpose(j1:j6)], "|") & "|"), "|"))
End Sub

 

[snb]

Als In A1:An de klantnamen
Als in B1:B6 de foldernamen

In D1:

=IF(MOD(ROW($A1)-1;6)=0;INDEX($A$1:$A$1500;INT((ROW($A1)-1)/6)+1);"")

In E1:

 =INDEX($B$1:$B$6;MOD(ROW(A1)-1;6)+1)

en doortrekken tot D9000:E9000

 

[VenA]

Of met Power Query