VBA transposing an array with parameters-CodePudding

I've managed to record all changes my team has done and in order to use it further I'll need to transpose the table into format supported by our systems. I was able to transpose one row but there are hundreds in my file so my code was useless.

My input table look like this

My goal for output looks like this

I've managed to transpose the whole table from tutorial (Essential Excel), however it doesn't fit my needs.

Sub TransposeTest()

Dim wks As Worksheet, wks2 As Worksheet
Dim MyArray As Variant
Dim LastRow As Integer, LastColumn As Integer
Dim StartCells As Range

Set wks = ThisWorkbook.Sheets("Sheet1")
Set wks2 = ThisWorkbook.Sheets("Transpose")
Set StartCell = wks.Range("A2")

LastRow = wks.Cells(wks.Rows.Count, StartCell.Column).End(xlUp).row
LastColumn = wks.Cells(StartCell.row, wks.Columns.Count).End(xlToLeft).Column

MyArray = wks.Range(StartCell, wks.Cells(LastRow, LastColumn)).Value2

MyArray = WorksheetFunction.Transpose(MyArray)

wks2.Range("a2", wks2.Cells(LastColumn, LastRow)).Value = MyArray

End Sub

I've been advised to use array for months and loop through each row however I unable to achieve it.

CodePudding user response：

Please, try the next code. It should be very fast, even for large ranges. It uses arrays and works only in memory, the result being dropped at once:

Sub TransposeData()
  Dim sh As Worksheet, shTr As Worksheet, lastR As Long, arr, arrfin, ArrH, i As Long, k As Long, j As Long
  
  Set sh = ActiveSheet
  Set shTr = sh.Next  'use here the sheet you need to return.
                      'if the next sheet is empty you can let the code as it is
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
  
  arr = sh.Range("A1:Q" & lastR).value                          'place the range in an array for faster iteration
  ReDim arrfin(1 To UBound(arr) * 12   1, 1 To 7): k = 1        'redim the final array dimensions
  ArrH = Split("Index,Person,Dept,Month,Sales,STMP,User", ",")  'create an array from the header strings
  'place the headers in the first row of the final array:
  For i = 0 To UBound(ArrH): arrfin(k, i   1) = ArrH(i): Next: k = k   1
  'build the final array:
  For i = 2 To UBound(arr)
        For j = 1 To 12
            arrfin(k   j - 1, 1) = arr(i, 1): arrfin(k   j - 1, 2) = arr(i, 2): arrfin(k   j - 1, 3) = arr(i, 3)
            arrfin(k   j - 1, 4) = j & "." & Year(Date): arrfin(k   j - 1, 5) = arr(i, j   3)
            arrfin(k   j - 1, 6) = arr(i, 16): arrfin(k   j - 1, 7) = arr(i, 17)
        Next j
        k = k   j - 1 'reinitialize k variable for the next data row
  Next i

  'drop the final array content at once, and do some formatting:
  With shTr.Range("A1").Resize(UBound(arrfin), UBound(arrfin, 2))
        .value = arrfin
        .rows(1).Font.Bold = True
        .EntireColumn.AutoFit
        For i = 7 To 9
            .Borders(i).Weight = xlThin
            .Borders.LineStyle = xlContinuous
        Next
 End With

 MsgBox "Ready..."
End Sub

CodePudding user response：

You can obtain your desired output using Power Query, available in Windows Excel 2010 and Office 365 Excel

Select some cell in your original table
Data => Get&Transform => From Table/Range or From within sheet
When the PQ UI opens, navigate to Home => Advanced Editor
Make note of the Table Name in Line 2 of the code.
Replace the existing code with the M-Code below
Change the table name in line 2 of the pasted code to your "real" table name
Examine any comments, and also the Applied Steps window, to better understand the algorithm and steps

M Code

let

//Change table name in next row to the actual table name in your workbook
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],

//set the data types
    #"Changed Type" = Table.TransformColumnTypes(Source,{
        {"Index", Int64.Type}, {"Person", Int64.Type}, {"Dept", Int64.Type}, 
        {"Jan", Int64.Type}, {"Feb", Int64.Type}, {"Mar", Int64.Type}, 
        {"Apr", Int64.Type}, {"May", Int64.Type}, {"Jun", Int64.Type}, 
        {"Jul", Int64.Type}, {"Aug", Int64.Type}, {"Sep", Int64.Type}, 
        {"Oct", Int64.Type}, {"Nov", Int64.Type}, {"Dec", Int64.Type}, 
        {"Time", type datetime}, {"User", type text}},"en-150"),

//Unpivot the Month columns
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", 
        {"Index", "Person", "Dept", "Time", "User"}, "Month", "Sales"),

//Transform "Month" column to "MonthNum.YearNum
//Not sure where the year should come from.
//   for now will just hard code at as 2022
//   but could use a different method.
    mnthCol = Table.TransformColumns(#"Unpivoted Other Columns", {"Month", each 
        Date.ToText(Date.FromText("1-" & _ & "-2022"),"M.yyyy"),type text}),

//Reorder the columns
    #"Reordered Columns" = Table.ReorderColumns(mnthCol,{"Index", "Person", "Dept", "Month", "Sales", "Time", "User"}),

//Rename the columns as per your example
    rename = Table.RenameColumns(#"Reordered Columns",{
        {"Time","STMP"},
        {"Dept","Depr"}
    })
in
   rename

Original Data

Parital Results