rijen omzetten naar kolommen

[Talldaddy]

Hallo

heb volgende vraag
ik weet dat het mogelijk is om rijen te transponeren naar kolommen

ik zit echter met een dilemma.
ik heb een database die aangeleverd is in tabelvorm
hierbij zitten gegevens die bij een item horen dus in meerdere rijen

kunnen de gegevens uit de diverse rijen omgezet naar kolommen zodat het een wat handiger format krijgt.

Waarschijnlijk kan dit wel met een macro, echter heb ik daar geen ervaring mee.

bijgevoegd voorbeeld van de layout zoals het nu is en hoe ik het zou willen
Bekijk bijlage help.xlsx

vast bedankt

 

[HSV]

Met zoiets als dit.

Sub hsv()
Dim rRng As Range, cl As Range, sq, j As Long, r As Long, c As Long, a As Long
With Sheets("Blad2")
Set rRng = Range("A2:C" & .Cells(Rows.Count, 3).End(xlUp).Row)
  sq = rRng
ReDim arr(UBound(sq), UBound(sq))
  For Each cl In rRng.Columns(1).SpecialCells(2)
       arr(r, c) = cl
               c = c + 1
       arr(r, c) = cl.Offset(, 1)
               c = c + 1
For j = 1 To .Cells(cl.Row, 3).CurrentRegion.Rows.Count
 If a < j Then a = j
       arr(r, c) = sq(cl.Row + j - 2, 3)
               c = c + 1
  Next j
    r = r + 1
    c = 0
  Next cl
     .UsedRange.ClearContents
     .Cells(1).Resize(, 3) = Array("stof", "naam", "synoniemen")
     .Cells(2, 1).Resize(r, a + 2) = arr
 End With
End Sub

 

[Talldaddy]

uitgeprobeerd

Hallo

heb scriptje uitgeprobeerd
krijg echter foutmelding:

fout 9 tijdens uitvoering
het subscript valt buiten het bereik

zal eens kijken of ik kan vinden waar het fout gaat

 

[Warme bakkertje]

Begin hier al eens mee.
Kijk dan ook na of de bladnaam correct is, want het werkt wel degelijk.

Sub hsv()
Dim rRng As Range, cl As Range, sq, j As Long, r As Long, c As Long, a As Long
With Sheets("Blad2")
Set rRng = [COLOR="#FF0000"].[/COLOR]Range("A2:C" & .Cells(Rows.Count, 3).End(xlUp).Row)
  sq = rRng
ReDim arr(UBound(sq), UBound(sq))
  For Each cl In rRng.Columns(1).SpecialCells(2)
       arr(r, c) = cl
               c = c + 1
       arr(r, c) = cl.Offset(, 1)
               c = c + 1
For j = 1 To .Cells(cl.Row, 3).CurrentRegion.Rows.Count
 If a < j Then a = j
       arr(r, c) = sq(cl.Row + j - 2, 3)
               c = c + 1
  Next j
    r = r + 1
    c = 0
  Next cl
     '.UsedRange.ClearContents
     .Cells(1,7).Resize(, 3) = Array("stof", "naam", "synoniemen")
     .Cells(2, 7).Resize(r, a + 2) = arr
 End With
End Sub

 

[HSV]

Misschien loopt het stuk op de tekst "lege regel" (verwijder dit).
Verwijder ook de waarden in de groene gewenste cellen.

 

[sylvester-ponte]

soms staat er na supplement(optioneel): nog iets.hoort dat bij het boven staande spul??
en moeten alle optionele supplementen na een "optionele" kolom geplaatst worden?

 

[HSV]

Volgens mij gaat het om blad2 Sylvester.

 

[sylvester-ponte]

dank Harry,
ik verwacht dat de zelfde macro ook moet werken voor blad 1

 

[HSV]

Met een aanpassing van de 'currentregion.rows.count' zou dit ook kunnen werken.