Array Transformation via Application.Index()
This approach assigns the table values to an array first and eventually transforms the same array to the wanted structure using the extended features of the Application.Index()
function thus maintaining the product names.
I don't pretend this to be the most efficient way, but it clearly demonstrates the possibilities of the cited function - c.f. Some pecularaties of the Application.Index function
Further note: I assume that all month data are included, i.e. even empty values.
Sub Table2PivotBase()
' Purpose: Transform Table to Pivot base
' Method: reorganize Datafield array of table using advanced features of Application.Index in [2]d)
' Note: sheet references use the worksheet's CodeName property here
'~~~~~~~~~~~~ [0] Reference to table (address) ~~~~~~
Const MONTHSCOUNT& = 12, COLUMNOFFSET& = 1 ' number of months, column offset January = 1 (i.e. 2nd col)
With Sheet1
'a) Refer to table using the sheet's CodeName
Dim rpt As ListObject
Set rpt = .ListObjects("Table1")
Sheet1.CodeName
' ~~~~~~~~~~~ [1] Get Data ~~~~~~~~~~~~~~~~~~~~~~~~
'b) Assign table values in Sheet1 to 2-dim 1-based array
Dim arr As Variant, yr&
arr = .Range(rpt.Range.Address).Value2
'c) Extract current year from 1st month column in header (1+ coloffset 1 => 2nd column)
yr = Val(Split(arr(1, 1 + COLUMNOFFSET) & "-", "-")(1))
End With
'~~~~~~~~~~~~~~ [2] Reorganize Data ~~~~~~~~~~~~~~~
'd) Redimension array preserving 1st column
Dim arr2, ItemsCount&
ItemsCount = UBound(arr) - IIf(rpt.ShowTotals, 1, 0) ' exclude table totals from items count
arr2 = Application.Index(arr, Application.Transpose(getRowsArr(ItemsCount, MONTHSCOUNT)), Array(1, 1, 1, 2))
'e) Redefine headers in 1st row
Dim no&, headers
headers = Array("Product", "Year", "Month", "Data")
For no = 1 To 4
arr2(1, no) = headers(no - 1) ' headers are zerobased
Next no
'f) Enter year, month & month data in a loop
Const START& = 2
Dim i&, mon&, ii&
ii = START - 1
For i = START To UBound(arr2)
mon = (i - START) Mod MONTHSCOUNT + 1 ' 0 to 11 (omitting 1 caption row) + 1
If mon = 1 Then ii = ii + 1 ' increment data row of arr1 in January
'arr2(i, 1) has already been prefilled by section [2]d)
arr2(i, 2) = yr
arr2(i, 3) = Application.Text(DateSerial(yr, mon, 1), "mmm")
arr2(i, 4) = arr(ii, mon + COLUMNOFFSET)
Next i
'~~~~~~~~~~~~ ~[3] Write back pivot base to any sheet (via CodeName) ~~~~~~~~~~~
With Sheet2
.Range("A:D") = vbNullString
.Range("A1").Resize(UBound(arr2), UBound(arr2, 2)) = arr2
End With
End Sub
Helper function getRowsArr()
Function getRowsArr(ByVal ItemsCount, Optional ByVal n& = 12) As Variant()
' Purpose: return 1-dim 0-based array containing n row numbers per item + title row no 1
' Note: allows restructuring the original array to contain all months data
Const START& = 2 ' data rang starts in 2nd row
Dim tmp(), i&, ii&
ReDim tmp(0 To (ItemsCount - 1) * n) ' includes header row number 1 at tmp(0) - zerobound!
'1) fill temporary array
tmp(0) = 1 ' title row no equals 1
For i = START To ItemsCount ' row no 2 to ...
For ii = 0 To n - 1 ' repeat row number n times
tmp((i - START) * n + ii + 1) = i
Next ii
Next i
'2) return Array(1,2,2,2,2,2,2,2,2,2,2,2,2,3,........3,4...,...) as function value
getRowsArr = tmp
'Debug.Print Left$(Join(tmp, ","), 65) & "..."
End Function