Restructure Excel table with VBA

Question

I have an Excel table source (extract is below):

Models are changing (adding new names, removing), so does change Week number in Columns (from Now till end of the year)

I need to restructure it so that it could look like this:

So that it could be normally used for further querying. In each row there must be model name, for each model there should be Week number and corresponding matching Quantity taken from the table itself (on the intersection of Model X Week from original table). I was smashing my head against the wall on how it can be realized in VBA. Couldn't restructure it with simple code.

I think you could do it with two nested for...next, the first going from fist to last data rows, and the other going to first to last data columns, copying values to a new sheet where you'll write `current line's first cell (row header)`, `current column's first cell (column header)` and `current line x current column cell (actual value)`. Please edit your question adding your code for further assistance. — VBobCat, Apr 14 '21 at 21:35
You could do this with VBA but you could also do it with only a few steps using Power Query. if you used VBA you would need to run the code every time there was an update ,with Power Query it would update automatically when new data was added to the original table. — norie, Apr 14 '21 at 21:37
see second answer here: https://stackoverflow.com/questions/20541905/convert-matrix-to-3-column-table-reverse-pivot-unpivot-flatten-normal — Scott Craner, Apr 14 '21 at 21:43

norie · Answer 1 · 2021-04-14T23:04:23.617

You could do this with VBA but you could also do it with only a few steps using Power Query.

VBA Method

Here's code to do it with VBA, it assumes the data to restructure is in a sheet named Data and starts at A1.

In this code the restructured data is put on a new sheet but you could change that to put it on an existing sheet.

Option Explicit

Sub RestructureData()
Dim ws As Worksheet
Dim arrDataIn As Variant
Dim arrDataOut() As Variant
Dim cnt As Long
Dim idxCol As Long
Dim idxRow As Long

    arrDataIn = Sheets("Data").Range("A1").CurrentRegion.Value
    
    ReDim arrDataOut(1 To (UBound(arrDataIn, 1) - 1) * (UBound(arrDataIn, 2) - 1), 1 To 3)
    
    For idxRow = LBound(arrDataIn, 1) + 1 To UBound(arrDataIn, 1)
        
        For idxCol = LBound(arrDataIn, 2) + 1 To UBound(arrDataIn, 2)
            cnt = cnt + 1
            arrDataOut(cnt, 1) = arrDataIn(idxRow, 1)
            arrDataOut(cnt, 2) = arrDataIn(1, idxCol)
            arrDataOut(cnt, 3) = arrDataIn(idxRow, idxCol)
        Next idxCol
        
    Next idxRow
    
    Set ws = Sheets.Add ' can be set to existing worksheet
    
    ws.Range("A1:C1").Value = Array("Model", "Week", "Quantity")
    
    ws.Range("A2").Resize(cnt, 3).Value = arrDataOut
    
End Sub

Power Query Method

Go to the sheet with the data, then go to the Data>Get & Transform Data tab.

Select From Table/Range, make sure all the data is selected and Does your data have headers? is ticked.

In Power Query select the Model column, right click and select Unpivot Other Columns.

Rename the Attribute column 'Week' and the value column 'Quantity' by double click each column header.

Click Close & Load to return the data to Excel.

This is the M Code those steps produce.

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Models", type text}, {"2021-03-29_(W13)", Int64.Type}, {"2021-04-05_(W14)", Int64.Type}, {"2021-04-12_(W15)", Int64.Type}, {"2021-04-19_(W16)", Int64.Type}, {"2021-04-26_(W17)", Int64.Type}}),
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Models"}, "Attribute", "Value"),
    #"Renamed Columns" = Table.RenameColumns(#"Unpivoted Other Columns",{{"Attribute", "Week"}, {"Value", "Quantity"}})
in
    #"Renamed Columns"

Thank you! Power Query method has one demerit. It queries the original table (which is updated by manual file uploading periodically) based on fixed field parameters. In my case it's Week Numbers, they are updated (past weeks are deleted, new ones are added). Is there a dynamic Unpivotting? Can I point only Fields that need not to be Unpivotted and others (without explicit naming like above) - make Unpivot? — SuperMaximus, Apr 15 '21 at 09:16
@SuperMaximus Didn't consider the data would expand in that way, even though it's kind of obvious. I think the problem might not be with the unpivot step, the only column/field mentioned there is the 'Model' field, but with the '# Changed Type' step where the column names are hard-coded. I'll have a look at that and update my answer if I come up with something, might be as simple as removing the step. — norie, Apr 15 '21 at 09:25

score 0 · Answer 2 · answered Apr 14 '21 at 22:49

try this code, just change the name of your sheets I used 2, the first is the source and the second is the destination, I hope help you

good Luck

Sub RestructureTable()
    Const SourceSheetName = "Source", DestinationSheetName = "Restructure" 'Your sheet names
    Dim nRowCounter As Double, nColumnSourceCounter As Double, nRowSourceCounter As Double
    '--------
    '-------Set the headers in destination sheet
    Sheets(DestinationSheetName).Range("A1") = "Models"  'Replace "Models" as you need
    Sheets(DestinationSheetName).Range("B1") = "Week"  'Replace "Week" as you need
    Sheets(DestinationSheetName).Range("C1") = "Qty"  'Replace "Qty" as you need
    '--------            
'----------------------------------------------------
    Sheets(SourceSheetName).Select 'Select the source sheet
    Range("A2").Select ' select the first cell with data
    nRowCounter = 2 ' Start in 2 cuase headers
    '---------------------------------------------------
    nRowSourceCounter = ThisWorkbook.Application.WorksheetFunction.CountA(Range("A:A"))     'count rows
    nColumnSourceCounter =     ThisWorkbook.Application.WorksheetFunction.CountA(Range("1:1")) 'count columns


    For r = 2 To nRowSourceCounter
        For c = 2 To nColumnSourceCounter
            'Model
            Sheets(DestinationSheetName).Range("A" & nRowCounter) =     Sheets(SourceSheetName).Cells(r, 1)
            'Header:Week
            Sheets(DestinationSheetName).Range("B" & nRowCounter) =   Sheets(SourceSheetName).Cells(1, c)
            'Qty
            Sheets(DestinationSheetName).Range("C" & nRowCounter) = Sheets(SourceSheetName).Cells(r, c)
            nRowCounter = nRowCounter + 1
        Next c
    Next r

End Sub

Restructure Excel table with VBA

2 Answers2

VBA Method

Power Query Method