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

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.

user_478884 · Answer

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

user_9199828 · Answer

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.

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

2 Answers