CODEWITHSUNDEEP
excelvba
Efernity92
Efernity92

Reputation: 27

VBA transposing an array with parameters

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

Input

My goal for output looks like this

Output

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.

Upvotes: 1

Views: 517

Answers (2)

Ron Rosenfeld
Ron Rosenfeld

Reputation: 60174

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
enter image description here

Partial Results
enter image description here

Upvotes: 2

FaneDuru
FaneDuru

Reputation: 42236

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

Upvotes: 3

Related Questions