Since it seems to come up every now and then, here's a quick generic routine/idea for reshaping single columns of data:
Code:
Option Explicit
' --------------------------------------------------------
' DECLARE APIs
' --------------------------------------------------------
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
nDestPtr As Any, _
nSrcPtr As Any, _
ByVal nLenB As Long _
)
Private Sub Example()
Dim Rng As Range
Set Rng = ActiveSheet.Cells(1).Resize(1000)
Rng.Formula = "=1 + MOD(ROW(A1) - 1, 10)"
Rng(, 3).Resize(10, 100).Value = Reshape(Rng, nColLen:=10)
End Sub
Private Function Reshape(rSrc As Range, nColLen As Long) As Variant
' -----------------------------------------------------------------
' RETURNS: An array holding the contents of rSrc reshaped
' as an (nColLen x AppropWidth) array
' -----------------------------------------------------------------
' Validate arguments
If (rSrc.Cells.Count / nColLen) <> (rSrc.Cells.Count \ nColLen) Then Exit Function
' Read input
Dim vSrc As Variant
vSrc = rSrc.Value
' Get location of vSrc's SafeArray structure
Dim nPtrToSA As Long
CopyMemory nPtrToSA, ByVal VarPtr(vSrc) + 8, 4
' Alter number of rows
CopyMemory ByVal nPtrToSA + 16, rSrc.Cells.Count \ nColLen, 4
' Alter number of cols
CopyMemory ByVal nPtrToSA + 24, nColLen, 4
' Return altered array
Reshape = vSrc
End Function
Last edited: