Paste Special Transpose in larger mode

Hello. I need to do Paste Special Transpose function in larger mode. I need Transpose three cells at once.
Transpose.png

Hi -

You can try this one;

Sub test()
Dim rng(), rng2(),i as long, ii As long
rng = Range("a1").currentregion
ii = 0
For i = 1 To UBound(rng) Step 3
    ReDim Preserve rng2(UBound(rng) / 3, 3)
    rng2(ii, 0) = rng(i, 1): rng2(ii, 1) = rng(i + 1, 1): rng2(ii, 2) = rng(i + 2, 1)
    ii = ii + 1
Next
Cells(1, 2).Resize(UBound(rng2), 3) = rng2
Erase rng: Erase rng2
End Sub

Regards,
Event