horizontaal transponeren

[moensk]

ik heb in november 2019 al eens vraag gepost (deze staat al op gesloten vandaar nieuwe vraag) en toen een script gekregen
het script transponeert 1 kolom
nu had ik daar graag een aanpassing op gehad zodat 2 kolommen getransponeerd worden.
in bijlage een voorbeeld om aan te tonen

script van toen

Sub hsv()
Dim sv, i As Long, ii As Long, s0 As String, n As Long, s As Long, b
sv = Cells(1).CurrentRegion
ReDim a(UBound(sv), UBound(sv))
n = 1
For i = 2 To UBound(sv)
 a(0, 0) = sv(1, 1)
 s = 0
     If InStr(s0, "|" & sv(i, 1) & "|") = 0 Then
                s0 = s0 & "|" & sv(i, 1) & "|"
                a(n, 0) = sv(i, 1)
         For ii = i To UBound(sv)
            If sv(ii, 1) = sv(i, 1) Then
                       s = s + 1
                       a(0, s) = "opmerking " & s
               a(n, s) = sv(ii, 2)
           End If
         Next ii
       n = n + 1
    End If
    If s > b Then b = s
  Next i
 Cells(1, 5).Resize(n, b + 1) = a
End Sub

 

[HSV]

Sub hsv()
Dim sv, i As Long, j As Long, ii As Long, s0 As String, n As Long, s As Long, b
sv = Cells(15, 1).CurrentRegion
ReDim a(UBound(sv), UBound(sv) * 2)
n = 1
For i = 2 To UBound(sv)
 a(0, 0) = sv(1, 1)
 s = 0
     If InStr(s0, "|" & sv(i, 1) & "|") = 0 Then
                s0 = s0 & "|" & sv(i, 1) & "|"
                a(n, 0) = sv(i, 1)
         For ii = i To UBound(sv)
            If sv(ii, 1) = sv(i, 1) Then
                For j = 0 To 1
                       s = s + 1
                       a(0, s) = sv(1, j + 2)
                       a(n, s) = sv(ii, j + 2)
                Next j
           End If
         Next ii
       n = n + 1
    End If
    If s > b Then b = s
  Next i
 Cells(25, 5).Resize(n, b + 1) = a
End Sub

 

[moensk]

HSV bedankt voor snelle reactie
ik krijg een fout 13 na ReDim a(UBound(sv), UBound(sv) * 2)

 

[HSV]

Er staat basis bovenaan; haal dat weg.

 

[HSV]

Hier je bestand.
Ik moet ervan tussen.

 

[moensk]

HSV,
ik had alle rijen al weg gehaald, zodat er maat 1 kopregel was doch ook dan krijg ik de melding

 

[moensk]

HSV thanks voor bestand !

 

[moensk]

HSV, mijn fout gevonden, opgelost , thanks

 

[VenA]

Andere optie zie Sheet1

Sub VenA()
  With Sheets("Sheet1")
    ar = .Cells(1).CurrentRegion
    Set d = CreateObject("Scripting.Dictionary")
    For j = 2 To UBound(ar)
      d(ar(j, 1)) = d(ar(j, 1)) & ar(j, 2) & "|" & ar(j, 3) & "|"
    Next j
    .Cells(1, 5).Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    .Columns(6).TextToColumns .Cells(1, 6), 1, , , , , , , , "|"
  End With
End Sub