Rearranging a table layout into a custom format

[ajaysomasi]

Hi all

Appreciate if you can provide me with a VBA to undertake the below task..

I want the program to take 1 under each column and report the applicable rows for that column in the format shown after the table.. Appreciate your help..

	Subject A	Subject B	Subject C
Row1	1	N	1
Row2	N	N	1
Row3	1	N	N
Row4	N	1	N
Row5	1	1	N

The resulting format should be:

Subject A
Row1
Row3
Row5

Subject B
Row4
Row5

Subject C
Row1
Row2

 

[alansidman]

Book12
	A	B
1	Column1	Attribute
2	Row3	Subject A
3	Row5	Subject A
4	Row1	Subject A
5	Row5	Subject B
6	Row4	Subject B
7	Row2	Subject C
8	Row1	Subject C
Sheet6

With Power Query, Unpivot your data and sort your columns

let
    Source = Excel.CurrentWorkbook(){[Name="Table5"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Subject A", type any}, {"Subject B", type any}, {"Subject C", type any}}),
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Column1"}, "Attribute", "Value"),
    #"Filtered Rows" = Table.SelectRows(#"Unpivoted Other Columns", each ([Value] = 1)),
    #"Sorted Rows" = Table.Sort(#"Filtered Rows",{{"Attribute", Order.Ascending}}),
    #"Removed Columns" = Table.RemoveColumns(#"Sorted Rows",{"Value"})
in
    #"Removed Columns"

 

[DanteAmor]

Try this. Your data on Sheet1 starting in cell A1, results on Sheet2

Dante Amor
	A	B	C	D
1		Subject A	Subject B	Subject C
2	Row1	1	N	1
3	Row2	N	N	1
4	Row3	1	N	N
5	Row4	N	1	N
6	Row5	1	1	N
Sheet1

Dante Amor
	A
1
2	Subject A
3	Row1
4	Row3
5	Row5
6
7	Subject B
8	Row4
9	Row5
10
11	Subject C
12	Row1
13	Row2
14
Sheet2

Sub Rearranging_table()
  Dim i As Long, j As Long, k As Long, lr As Long, lc As Long, m As Long
  Dim a As Variant
  
  With Sheets("Sheet1")
    lr = .Range("A" & Rows.Count).End(3).Row
    lc = .Cells(1, Columns.Count).End(1).Column
    a = .Range("A1", .Cells(lr, lc)).Value2
  End With
  ReDim b(1 To (UBound(a, 1) * UBound(a, 2)) + (UBound(a, 2) * 2), 1 To 1)
  
  k = 1
  For j = 2 To UBound(a, 2)
    m = k
    For i = 2 To UBound(a, 1)
      If a(i, j) = 1 Then
        k = k + 1
        b(m, 1) = a(1, j)
        b(k, 1) = a(i, 1)
      End If
    Next i
    If m <> k Then k = k + 2
  Next j
  Sheets("Sheet2").Range("A:A").ClearContents
  Sheets("Sheet2").Range("A2").Resize(k, 1).Value = b
End Sub

 

[ajaysomasi]

Many thanks.. this will be quite helpful..

 

[DanteAmor]

Glad we could help & thanks for the feedback