1 regel maken van meerdere regels

[IlonadeGroot]

Hallo allemaal,

Ik ben benieuwd of het mogelijk is om van meerdere regels 1 regel te maken.
Ik heb een bestand met een aantal kolommen.
Die 5 regels (aantal regels kan per artikel verschillen) hebben in alle kolommen behalve 1 dezelfde waardes.
Het gaat mij dus om de waardes van 1 kolom die ik eigenlijk liever met de andere gegevens in 1 regel zou willen hebben.
Zie het bijgevoegde voorbeeld bestandje.
Iemand die een idee heeft?

Alvast bedankt! Bekijk bijlage 1 regel maken.xlsx

 

[HSV]

Maak een tweede blad aan in je bestand.
Laat de code eens lopen, en bekijk het resultaat in het tweede blad.

Sub hsv()
 Dim dic As Object, a, i As Long, e, s, n As Long
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
     a = Sheets(1).Range("a1").CurrentRegion.Value
        For i = 2 To UBound(a, 1)
            If Not dic.exists(a(i, 1)) Then
                Set dic(a(i, 1)) = CreateObject("Scripting.Dictionary")
                dic(a(i, 1)).CompareMode = 1
            End If
             dic(a(i, 1))(a(i, 2)) = dic(a(i, 1))(a(i, 2))
             dic(a(i, 1))(a(i, 3)) = dic(a(i, 1))(a(i, 3))
        Next i
          With Sheets(2).Cells(1)
           .CurrentRegion.ClearContents
           .Resize(dic.Count).Value = Application.Transpose(dic.keys)
          End With
  For Each e In dic
      For Each s In dic(e)
            dic(e)(s) = s & dic(e)(s)
          Next s
       n = n + 1
         Sheets(2).Cells(n, 2).Resize(, dic(e).Count).Value = dic(e).items
      Next e
      Sheets(2).Columns.AutoFit
End Sub

 

[IlonadeGroot]

Harry,

Super bedankt! Werkt perfect :thumb:

Groetjes Ilona

 

[IlonadeGroot]

Ik heb nog 1 vraagje als het mag. Ik heb gevonden waar ik in de code de kolom aan kan passen waar de verschillende data in staat, maar ik kan niet vinden waar ik het aantal kolommen aan kan geven, die ik weergegeven wil hebben.
Ik heb nu b.v. een bestandje met 6 kolommen. De laatste kolom is degene met de verschillende data, maar ik wil ook graag de overige 5 kolommen terug zien.

Zie het toegevoegde plaatje, waar ik het vierkantje in rood heb neergezet heb ik gevonden dat dat de kolom is met de verschillende gegevens. Kunt u mij misschien ook aangeven waar ik het aantal kolommen aan kan passen???



Alvast weer bedankt!!
Groetjes Ilona

 

[HSV]

Zonder een voorbeeldbestandje is het gokken wat je bedoeld.

dic(a(i, 1))(a(i, 2)) = dic(a(i, 1))(a(i, 2))
             dic(a(i, 1))(a(i, 3)) = dic(a(i, 1))(a(i, 3))
             dic(a(i, 1))(a(i, 4)) = dic(a(i, 1))(a(i, 4))
             dic(a(i, 1))(a(i, 5)) = dic(a(i, 1))(a(i, 5))
             dic(a(i, 1))(a(i, 6)) = dic(a(i, 1))(a(i, 6))

 

[IlonadeGroot]

Hallo Harry,

Het is hem bijna. Ik voeg een voorbeeld bestandje bij. Zoals je ziet zijn alle kolommen verschillende waardes. Echter in kolom 4&5 zie je b.v. 2x vlees staan. Dit moeten echter aparte kolommen blijven en alleen de waarden uit de laatste kolom zijn echt verschillende waardes op de verschillende regels. Als ik nu je code gebruik, zet ie bij die artikelen waar vlees achter elkaar staat in de kolommen, maar 1x de waarde vlees neer, dus de tweede kolom met vlees blijft achterwege.

Alvast bedankt weer

 

[HSV]

Hallo Ilona,

Dan moet het zoiets worden.

Sub hsv()
Dim Rng As Range, cl As Range, n As Long, y As Long
Application.ScreenUpdating = False
Sheets(2).Range("A1").CurrentRegion.ClearContents
With Sheets(1)
Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
For Each cl In Rng
    If Not .Exists(cl.Value) Then
        n = n + 1
        .Add cl.Value, Array(n, 1)
        Sheets(2).Range("A" & n).Resize(, 6) = cl.Resize(, 6).Value
        y = 5
    Else
        y = y + 1
          Sheets(2).Range("A" & n).Offset(, y) = cl.Offset(, 5).Value
    End If
   Next
     End With
   End With
   Sheets(2).Columns.AutoFit
End Sub

 

[IlonadeGroot]

Hoi harry,

Dan krijg ik de melding dat de subscript out of range is.

 

[HSV]

Hoi,

Hier niet.
Laat de code lopen en kijk op blad1.

 

[IlonadeGroot]

Helemaal super!! Dankjewel