Single Column --> 2d Grid

[James_B]

Since it seems to come up every now and then, here's a quick generic routine/idea for reshaping single columns of data:

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

 

[Akihito Yamashiro]

Hello James_B.

That's very interestring idea, isn't it?
And is there any problem on the function?

 

[James_B]

Not that I know of, no. Though you have to be careful when tinkering with a SafeArray struct like this. There are only a limited number of moves you can make. In this case, since I'm starting with an array read from a range, there are a lot more knowns.

 

[James_B]

For safety's sake, by the way, I'd recommend the following (I've put a guard around the CopyMemory functions in case a null pointer is in play)

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
 
   if nPtrToSA then
      ' 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 if
End Function