Bundelen / Transponeren van gegevens vanuit meerdere kolommen

[MickT]

Ik wil gegevens uit meerdere kolommen bundelen, zie voorbeeld.

kolom B, D, F, H, J -> komt dan onder elkaar in kolom B
Kolom C, E, G, I, K -> komt dan onder elkaar in kolom C

Ik hoor het graag als iemand een tip heeft. Bij voorbaat dank.

 

[snb]

Sub M_snb()
   sn = Sheet1.Cells(1).CurrentRegion
   ReDim sp((UBound(sn) - 1) * (UBound(sn, 2) - 1) \ 2, 2)
   
   For j = 0 To UBound(sp) - 1
     x = j Mod (UBound(sn) - 1) + 2
     y = 2 * (j \ (UBound(sn) - 1))
     sp(j, 0) = sn(x, 1)
     sp(j, 1) = sn(x, 2 + y)
     sp(j, 2) = sn(x, 3 + y)
    Next
    
    Cells(12, 5).Resize(UBound(sp), UBound(sp, 2) + 1) = sp
End Sub

 

[MickT]

Bedankt voor je reactie snb!

Ik begrijp dat dit een toevoeging is voor VBA, maar voor mij is dit nog steeds abacadabra. Kun je mij iets verder op weg helpen?

 

[snb]

Nee, dan kun je je beter bij knippen en plakken houden.

 

[OctaFish]

In het meegeleverde bestand heet het werkblad anders, dus moet je ook een regel aanpassen. En de doellocatie moet ook een beetje anders. Je komt dan uit op deze macro:

Sub M_snb()
   sn = [B]Blad1[/B].Cells(1, 1).CurrentRegion
   ReDim sp((UBound(sn) - 1) * (UBound(sn, 2) - 1) \ 2, 2)
   
   For j = 0 To UBound(sp) - 1
     x = j Mod (UBound(sn) - 1) + 2
     y = 2 * (j \ (UBound(sn) - 1))
     sp(j, 0) = sn(x, 1)
     sp(j, 1) = sn(x, 2 + y)
     sp(j, 2) = sn(x, 3 + y)
    Next
    
    Cells([B]8, 1[/B]).Resize(UBound(sp), UBound(sp, 2) + 1) = sp
End Sub

 

[AlexCEL]

Hierbij nog een optie met Power Query.

Edit: ook nog een optie met een VERSCHUIVING-formule.

 

[MickT]

AlexCEL, de Power Query werkt perfect, bovendien kan ik deze eenvoudig aanpassen. Ontzettend bedankt!

 

[MickT]

Snb en Octafish, jullie ook bedankt voor je bijdrage.

 

[JEC.]

De code van Snb wat aangepast om exact je gewenste resultaat te verkrijgen.:thumb:

Sub jvr()
     jv = Sheets(1).Cells(1, 1).CurrentRegion
     ReDim ar((UBound(jv) - 1) * (UBound(jv, 2) - 1) \ 2, 2)
     
     For j = 0 To UBound(ar) - 1
        x = (j Mod (UBound(jv) - 1)) * 2 + 2
        y = j \ (UBound(jv) - 1) + 2
        ar(j, 0) = jv(y, 1)
        ar(j, 1) = jv(y, x)
        ar(j, 2) = jv(y, x + 1)
     Next
 
     Cells(8, 15).Resize(UBound(ar), UBound(ar, 2) + 1) = ar
End Sub