Unpivot data?

[Slicemahn]

Hi VbExpress Nation,

I have a challenge with a data set in which I want to change columnar data into tabular. I have attached the spreadsheet with the issue and the desired result as the second tab.


I was thinking of doing something like this:

Sub Test()
Dim LastRow as Integer
Dim LastCol as Integer
Dim RowHop as Integer
Dim ColHop as Integer
LastRow = Cells(Rows.Count, 1).End(xlup).row
LastCol = Cells (1,Columns.Count).End(xltoLeft).column

For RowHop = LastRow to 2 step-1
For ColHop = LastCol to 4 Step -1
If Cells (RowHop, ColHop) <> "" then
Rows(RowHop +1).Insert
Cells(RowHop +1,1)=Cells(RowHop,1)
Cells(RowHop +2,1)=Cells(RowHop, ColHop)
Cells(RowHop, ColHop).Clear
Else: Rows(RowHop).Delete
End if
Next
Next
End Sub

I am hopeful that someone can take a look with fresh eyes and show me where I went wrong.

Thanks in advance for your help.

[david000]

If you upload the table to PowerQuery and select the first three columns and right click and select 'unpivot other columns' your done. Just a suggestion.


snip_20190319203539.jpg

[大灰狼1976]

Hi Slicemahn!
something like below

Sub Test()
Dim arr, arrRst, i&, j&, r&
arr = Sheets("Course Matrix").[a1].CurrentRegion
ReDim arrRst(1 To (UBound(arr) - 1) * (UBound(arr, 2) - 3), 1 To 5)
For i = 2 To UBound(arr)
  For j = 4 To UBound(arr, 2)
    r = r + 1
    arrRst(r, 1) = arr(i, 1)
    arrRst(r, 2) = arr(i, 2)
    arrRst(r, 3) = arr(i, 3)
    arrRst(r, 4) = arr(1, j)
    arrRst(r, 5) = arr(i, j)
  Next j
Next i
With Sheets("Desired Result")
  .UsedRange.ClearContents
  .[a2].Resize(r, 5) = arrRst
End With
End Sub

[snb]

This is what Powerquery does:

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion.Rows(1)
  c00 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml"""
  c01 = "`" & Sheet1.Name & "$`"
  
  For j = 4 To UBound(sn, 2)
    With CreateObject("ADODB.Recordset")
        .Open "Select `" & Join(Array(sn(1, 1), sn(1, 2), sn(1, 3)), "`,`") & "`, """ & sn(1, j) & """, `" & sn(1, j) & "` from " & c01, c00
        Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset .DataSource
     End With
   Next
End Sub

[Tom Jones]

snb,

get Run-time error '-24721790 (80040e14)': query syntax error...

.Open "Select `" & Join(Array(sn(1, 1), sn(1, 2), sn(1, 3)), "`,`") & "`, """ & sn(1, j) & """, `" & sn(1, j) & "` from " & c01, c00

when run your VBA code.
Can you fixit?

[snb]

To amend the failing fieldname in column A:

Sub M_snb()
  Sheet1.Cells(1) = "Name"
  sn = Sheet1.Cells(1).CurrentRegion.Rows(1)
  c00 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml"""
  c01 = "`" & Sheet1.Name & "$`"
  
  For j = 4 To UBound(sn, 2)
    With CreateObject("ADODB.Recordset")
        .Open "Select `" & Join(Array(sn(1, 1), sn(1, 2), sn(1, 3)), "`,`") & "`, """ & sn(1, j) & """, `" & sn(1, j) & "` from " & c01, c00
        Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset .DataSource
     End With
  Next

  Sheet2.UsedRange.Sort Sheet2.UsedRange.Cells(1)
  Sheet2.UsedRange.Offset(-1).Resize(1) = Array(sn(1, 1), sn(1, 2), sn(1, 3), "course", "yes/no")
End Sub

[Tom Jones]

Thank you snb.
Now is OK, but not sorted and no headers.

[snb]

Look at my last posted code: it contains a sorting method.
You can add anything to the code you want to yourself (e.g. headers like i did in http://www.vbaexpress.com/forum/show...l=1#post389114)

[Tom Jones]

OK. Thank you.