Excel 1 rij transponeren en dubbele regels verwijderen

[globe]

Goedendag,

Ik heb een Excel waar data onder elkaar staan die ik wil inkorten.

In bijgaand voorbeeld moet er naar artikelnummer (kolom 3) en maat (kolom 5) gekeken worden.

Deze maten, moeten achter elkaar geplaatst worden en door bv. een komma gescheiden worden. Of liggend streepje oid.

Vervolgens moet de lijst worden ingekort zodat er geen dubbele waarden achter blijven.

Ooit heb ik onderstaand script gebruikt om een soortgelijk resultaat te krijgen op basis van een andere file, zie topic: https://www.helpmij.nl/forum/showthread.php/865801-transponeren-op-basis-van-inhoud-kolom-A

maar ik krijg het niet voor elkaar deze werkend te krijgen.

Wie wil me even op weg helpen?

alvast bedankt!

Guido

Sub ff()
Dim Output() As Variant
    
    Tabel = Sheets(1).Cells(1).CurrentRegion
    x = 0
    For i = 2 To UBound(Tabel, 1)
        If Tabel(i, 1) <> Tabel(i - 1, 1) Then
            x = x + 1
            ReDim Preserve Output(1 To x)
            For ii = 1 To 3
                Output(x) = Output(x) & Tabel(i, ii) & ","
            Next ii
        Else
            Output(x) = Output(x) & Tabel(i, 3) & ","
        End If
    Next i
    
    With Sheets.Add(after:=Sheets(Sheets.Count))
        .Cells(1).Resize(UBound(Output, 1), 1) = Application.Transpose(Output)
        .Columns(1).TextToColumns Comma:=True
    End With
    
End Sub

 

[VenA]

Sub VenA()
  ar = Sheets("Blad1").Cells(1).CurrentRegion
  Set d = CreateObject("Scripting.Dictionary")
  For j = 1 To UBound(ar)
    If d.exists(ar(j, 3)) Then d(ar(j, 3)) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), d(ar(j, 3))(4) & ", " & ar(j, 5)) Else d(ar(j, 3)) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), ar(j, 5))
   Next j
   Cells(1, 10).Resize(d.Count, 5) = Application.Index(d.items, 0, 0)
End Sub

 

[globe]

top! Dat gaat lekker.

Achter mijn data staan nog meer kolommen, hoe kan ik deze mee kopiëren? Deze vervallen nu namelijk.

En kan ik de gehele output ook naar een nieuw blad kopiëren?

 

[VenA]

1. Door meer kolommen aan de array toe te voegen.

Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), ar(j, 5)[COLOR="#FF0000"],ar(j, 6),etc[/COLOR])

2. Door naar het juiste blad te verwijzen.

[COLOR="#FF0000"]sheets("Blad2")[/COLOR].Cells(1, 10).Resize(d.Count, 5) = Application.Index(d.items, 0, 0)

 

[globe]

Helaas, ik krijg een foutmelding.

heb dit er van gebakken:

Sub VenA()
  ar = Sheets("Blad1").Cells(1).CurrentRegion
  Set d = CreateObject("Scripting.Dictionary")
  For j = 1 To UBound(ar)
    If d.exists(ar(j, 3)) Then d(ar(j, 3)) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), d(ar(j, 3))(4) & ", " & ar(j, 5), ar(j, 6), ar(j, 7), ar(j, 8)) Else d(ar(j, 3)) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), ar(j, 5), ar(j, 6), ar(j, 7), ar(j, 8))
   Next j
   Sheets("Blad2").Cells(1, 1).Resize(d.Count, 5) = Application.Index(d.items, 0, 0)
End Sub

 

[VenA]

Dan moet je maar even debuggen. Code wordt gemaakt obv voorbeeldbestandjes. Als dit niet strookt met de werkelijkheid dan moet je het zelf oplossen.

 

[HSV]

@globe,

Je hebt er waarschijnlijk lege kolommen tussen.

 

[globe]

Bedankt voor de hulp, lege cellen deden inderdaad het script de das om. 255 karakters ga ik sowieso nooit redden.

Ik ga er weer mee verder, bedankt allemaal tot zover.

Guido