Meerdere rijen met dezelfde waarde in aparte kolommen plaatsen

[detroyni]

Kunnen jullie mij helpen?
Ik heb een bestand met meerdere entrys van dezelfde id in de rijen die ik graag zou transponeren naar verschillende kolommen.

Wat ik wil bekomen is 1 rij met de verschillende url's in de kolommen erachter.

 

[HSV]

Een extra blad toevoegen met de naam Blad2 waar het resultaat in komt.

Sub hsv()
Dim sv, a, i As Long, j As Long, x As Long
sv = Sheets("blad1").Cells(1).CurrentRegion
ReDim b(UBound(sv) * 4)
  With CreateObject("scripting.dictionary")
   For i = 1 To UBound(sv)
            a = .Item(sv(i, 1))
                If IsEmpty(a) Then a = b
                    a(0) = sv(i, 1)
                     For j = 3 To 5
                      a(UBound(a)) = a(UBound(a)) + 1
                      a(a(UBound(a))) = sv(i, j)
                    Next j
                  .Item(sv(i, 1)) = a
           If x < a(UBound(a)) Then x = a(UBound(a))
          Next i
    Sheets("blad2").Cells(1).Resize(.Count, x + 1) = Application.Index(.items, 0)
  End With
End Sub

 

[JEC.]

Ook nog een optie. Ook blad 2 even aanmaken voor deze.

Sub jvr()
 jv = Sheets(1).Cells(1, 1).CurrentRegion
   With CreateObject("scripting.dictionary")
       For i = 1 To UBound(jv)
         .Item(jv(i, 1)) = .Item(jv(i, 1)) & jv(i, 3) & "|" & jv(i, 4) & "|" & jv(i, 5) & "|"
       Next
     Sheets(2).Cells(1, 1).Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
    Sheets(2).Cells(1, 2).Resize(.Count).TextToColumns Sheets(2).Cells(1, 2), 1, , , , , , , 1, "|"
   End With
End Sub