How to turn a column of data into an 8x12 grid? - excel

Question

I'm trying to put values from 1 column into an 8x12 grid.
With the first value starting in the top left of the grid, moving to the right 12 cells, then offsetting 1 row from starting cell and having the data continue filling cells in this format.
I'm trying to replace
roneWS.Range("E6:N6") = Application.Transpose(ptWS.Range("B4:B13"))
roneWS.Range("C7:N7") = Application.Transpose(ptWS.Range("B14:B25"))
roneWS.Range("C8:N8") = Application.Transpose(ptWS.Range("B26:B37"))
roneWS.Range("C9:N9") = Application.Transpose(ptWS.Range("B38:B49"))
roneWS.Range("C10:N10") = Application.Transpose(ptWS.Range("B50:B61"))
roneWS.Range("C11:N11") = Application.Transpose(ptWS.Range("B62:B73"))
roneWS.Range("C12:N12") = Application.Transpose(ptWS.Range("B74:B85"))
roneWS.Range("C13:N13") = Application.Transpose(ptWS.Range("B86:B97"))
with an array/loop.
I came up with:
Dim ptWS As Worksheet, roneWS As Worksheet, rtwoWS As Worksheet, rthreeWS As Worksheet, rfourWS As Worksheet
Dim ptRng As Range, destRng As Range
Dim i As Integer
Dim ptArr() As Variant
Set ptWS = ThisWorkbook.Worksheets("PT")
Set roneWS = ThisWorkbook.Worksheets("WS1")
Set rtwoWS = ThisWorkbook.Worksheets("WS2")
Set rthreeWS = ThisWorkbook.Worksheets("WS3")
Set rfourWS = ThisWorkbook.Worksheets("WS4")
i = 4
Set ptRng = ptWS.Range("B4:B97") 'data that needs to be moved to other worksheets B4:B97 = 1st WS, C4:C97 = 2nd WS, D4:D97 = 3rd WS, E4:E97 = 4th WS
Set destRng = roneWS.Range("E6") 'destination range for WS1-WS4 starts at E6
ptArr = ptRng.Value 'setting all values for the WS1 to ptArr
For i = LBound(ptArr) To UBound(ptArr)
If ptArr(i, 1) = ptWS.Cells(14, 2) Then 'move my way across the columns until I hit Col O then, offset back to Col C and repeat until the end (N13) is reached
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(26, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(38, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(50, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(62, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(74, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(86, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
Else: destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
End If
Next i
It gives me what I want for WS1. However I have to repeat this for the 3 other worksheets.
For the other 3 worksheets, the total range is the same as posted above, just offset by 1 column.
WS1 = ptWS.Range("B4:B97")
WS2 = ptWS.Range("C4:C97")
WS3 = ptWS.Range("D4:D97")
WS4 = ptWS.Range("E4:E97")
The destination starting point on all 4 worksheets are the same Range(E6").
How do I add a loop through the worksheets once all cells on WS1 have been set, while also offsetting the column by 1 from ptWS. I'm wondering if this can be done without copy/pasting the existing array code 3 more times and just changing the ranges.
I achieved the same result by looping through the data on ptWS by using a series of Do Until loops but then eventually ran into the same issue.

Answer 1

Here's one appraoch:
Sub Tester()
Dim i As Long
For i = 1 To 4
ColToMatrix ThisWorkbook.Worksheets("PT").Range("B4:B97").Offset(0, i - 1), _
ThisWorkbook.Worksheets("WS" & i).Range("C6")
Next i
End Sub
'pass in the column to be mapped and the top-left destination cell for the matrix
Sub ColToMatrix(rngCol As Range, rngTL As Range)
Dim arr, mtx(1 To 8, 1 To 12), i As Long, r As Long, c As Long, n As Long
arr = rngCol.Value
For i = 1 To UBound(arr, 1)
n = i + 2 'account for starting 3 cells in
r = 1 + ((n - 1) \ 12)
c = ((n - 1) Mod 12) + 1
mtx(r, c) = arr(i, 1)
Next i
rngTL.Resize(8, 12).Value = mtx
End Sub

Answer 2

To do this, better way is doing a sub to transpose data, and then call it for every worksheet.
I'm excluding roneWS.Range("E6:N6") = Application.Transpose(ptWS.Range("B4:B13")) because it's not part of the 7x12 array, due to different size (it's 10 values, not 12).
So we focus on 7x12, this part of your code:
roneWS.Range("C7:N7") = Application.Transpose(ptWS.Range("B14:B25"))
roneWS.Range("C8:N8") = Application.Transpose(ptWS.Range("B26:B37"))
roneWS.Range("C9:N9") = Application.Transpose(ptWS.Range("B38:B49"))
roneWS.Range("C10:N10") = Application.Transpose(ptWS.Range("B50:B61"))
roneWS.Range("C11:N11") = Application.Transpose(ptWS.Range("B62:B73"))
roneWS.Range("C12:N12") = Application.Transpose(ptWS.Range("B74:B85"))
roneWS.Range("C13:N13") = Application.Transpose(ptWS.Range("B86:B97"))
This sub will as for:
A source range like ptWS.Range("B14:B97"), 84 values (7x12)
A destiny range like roneWS.Range("C7:N13"), a 7x12 grid
The code is:
Sub GET_VALUES(ByVal vRngSource As Range, ByVal vRngDestiny As Range)
Dim vMatriz As Variant
Dim ZZ As Long
Dim ThisColumn As Long, ThisRow As Long
ThisColumn = 1
ThisRow = 1
vMatriz = vRngSource.Value
For ZZ = 1 To UBound(vMatriz) Step 1
vRngDestiny.Cells(ThisRow, ThisColumn).Value = vMatriz(ZZ, 1)
If ThisColumn = 12 Then
ThisColumn = 1
ThisRow = ThisRow + 1
Else
ThisColumn = ThisColumn + 1
End If
Next ZZ
Erase vMatriz
End Sub
To call it, you can just do:
Sub test()
GET_VALUES Range("B14:B97"), Range("C7:N13")
End Sub
Now you just need to call it once for every worksheet. I would use a For each loop combined with Select Case, so you can choose for every worksheet what to do, like this:
Sub TEST()
Application.ScreenUpdating = False
Dim WK As Worksheet
Dim ptWS As Worksheet
Set ptWS = ThisWorkbook.Worksheets("PT")
For Each WK In ThisWorkbook.Worksheets
Select Case WK.Name
Case "WS1"
GET_VALUES ptWS.Range("B14:B97"), WK.Range("C7:N13")
WK.Range("E6:N6") = Application.Transpose(ptWS.Range("B4:B13"))
Case "WS2"
GET_VALUES ptWS.Range("C14:C97"), WK.Range("C7:N13")
WK.Range("E6:N6") = Application.Transpose(ptWS.Range("C4:C13"))
Case "WS3"
GET_VALUES ptWS.Range("D14:D97"), WK.Range("C7:N13")
WK.Range("E6:N6") = Application.Transpose(ptWS.Range("D4:D13"))
Case "WS4"
GET_VALUES ptWS.Range("E14:E97"), WK.Range("C7:N13")
WK.Range("E6:N6") = Application.Transpose(ptWS.Range("E4:E13"))
Case Else
'we do nothing
End Select
Next WK
Application.ScreenUpdating = True
End Sub
Hope you can adapt this to your needs.