Waardes van 1 Tabel in 1 kolommen rangschikken

[CvD3008]

Allereerst de beste wensen voor iedereen.

Ik probeer data vanuit een tabel in 1 kolom te rangschikken. De meest eenvoudige oplossing is om te knippen en plakken. Echter is dit wel een erg tijdrovend klusje.
Ik heb zelf al zitten stoeien met een draaitabel of een eenvoudige macro , echter kom ik hier niet uit.

In het bijgevoegde voorbeeld is er te zien welke data ik tot mijn beschikking heb en welke gewenst resultaat ik wil hebben.
Kan iemand mij hierbij helpen?

 

[cow18]

Sub Herschikken()
    Dim sn, sn1, k As Long
    sn = Sheets("Data").Range("A1").CurrentRegion 'je gegevens
    ReDim sn1(1 To UBound(sn) * UBound(sn, 2), 1 To 3) 'maak een array aan die alleszins groot genoeg is
    For i = 2 To UBound(sn, 2) 'je zones aflopen
        For j = 3 To UBound(sn) 'je gewichten aflopen
            k = k + 1 'oplopend tellertje
            sn1(k, 1) = sn(2, i) 'zone
            sn1(k, 2) = sn(j, 1) 'gewicht
            sn1(k, 3) = sn(j, i) 'bijbehorende prijs
        Next
    Next
    Sheets("Gewenst resultaat").Range("F" & Rows.Count).End(xlUp).Offset(1).Resize(k, 3) = sn1 'resultaat wegschrijven
End Sub

 

[CvD3008]

Fantastisch, precies wat ik zocht. Bedankt:d. Moet me toch maar eens verdiepen in de macro's.