transponeren naar meerdere regels.

[Iceje]

Goedenavond allemaal,

Vanuit mijn werk een vervelende uitdraai uit het bestelsysteem. Hierin staat in kolom A een set cijfers. In kolom B de klantnummer met een percentage.
Dit moet een klantnummer per kolom met huidige kolom A in een rij erachter en huidige kolom B in een rij daaronder.
huidig:
31007917
20 -40%
26 -42%
50 -48%
31015988
26 -42%
27 -26%
28 0%
51 -45%

Moet zijn:

20 26 27 28 50 51
31007917 -40% -42% -48%
20 26 27 28 50 51
31015988 -42% -26% 0% 0% -45%

Probleem zit hem nu voornamelijk in dat er een onevenredige string van nummers in de eerste rij is.
Ik hoop dat het beetje duidelijk is wat de bedoeling is. Ik heb een macro gevonden die een evenredig aantal rijen kan omzetten naar regels, maar dat is dus niet afdoende

Met Vriendelijk groet,
Iceje

 

[Timshel]

Maak er een voorbeeldbestand van. Dan hoeven we niet te gokken hoe het eruit moet komen te zien.

 

[Iceje]

Ja, ik zie nu dat he niet bepaald duidelijk is inderdaad.

hierbij een voorbeeldBekijk bijlage book1 .xlsx

De nummers in kolom A is bij iedere klant weer anders, maar er is wel een vast sting beschikbaar. van 1 tot en met 60

 

[Timshel]

... maar er is wel een vast sting beschikbaar. van 1 tot en met 60

Ik begrijp niet wat je hiermee bedoelt, maar probeer dit eens: Voeg een nieuw werkblad "Blad2" in voor de uitvoer en draai de macro.

Sub tsh()
    Dim Br, Bs, Bq
    Dim i As Long, t As Long
    
    Br = ActiveSheet.UsedRange
    With CreateObject("System.Collections.Arraylist")
        For i = 1 To UBound(Br)
            If Br(i, 1) = "" Then
                If Br(i, 2) <> "" Then t = t + 1
            Else
                If Not .Contains(Br(i, 1)) Then .Add Br(i, 1)
            End If
        Next
        .Sort
        Bs = .ToArray
    End With
    ReDim Bq(t, UBound(Bs) + 1)
    t = -1
    For i = 1 To UBound(Br)
        If Br(i, 1) = "" Then
            If Br(i, 2) <> "" Then
                t = t + 1
                Bq(t, 0) = Br(i, 2)
            End If
        Else
            Bq(t, Application.Match(Br(i, 1), Bs, 0)) = Br(i, 2)
        End If
    Next
    With Sheets("Blad2")
        .Cells(1, 2).Resize(, UBound(Bs) + 1) = Bs
        With .Cells(2, 1).Resize(UBound(Bq), UBound(Bq, 2) + 1)
            .Value = Bq
            .Offset(, 1).NumberFormat = "0%"
        End With
    End With
End Sub

 

[Iceje]

HELD !!!!

Super bedankt ! This does the trick.


Dit scheel mij zo ongelooflijk veel werk! gaat om meer dan 1000 klantnummers.. was al bang dat ik per stuk zou moeten knippen en plakken..