Excel: VBA to Add Row Name to and Column Headers to Row

[hpo2509]

Hi everyone. I am working on transposing a Column headers into rows based on if the cells under sales columns are more than zero. I am doing it manually but takes me so much time.
If anyone can possible suggest any codes to do this? example below

Employee Name	Employee Number	Manager	Sales 1	Sales 2	Sales 3	Sales 4	Sales 5
Danica	12345	Jenny	0	2	2	0	2
Robert	67890	Robert	1	2	0	5	0

What I want to achieve is this.

Danica	12345	Jenny	Sales 2	2
Danica	12345	Jenny	Sales 3	2
Danica	12345	Jenny	Sales 5	2
Robert	67890	Robert	Sales 1	1
Robert	67890	Robert	Sales 2	2
Robert	67890	Robert	Sales 4	5

Appreciate so much any insights.

 

[Alex Blakenburg]

What you are doing is called an unpivot an bread and butter for Power Query

• Click anywhere in your data set
• On the menu Date > From Table/Range (see image below)
• It will ask you if "Create Table" in My Table has headers should be ticked > hit ok
• PQ will fire up
• On the right remove the Changed type step (hit the x)
• Highlight the 1st 3 columns (Name -> Manager)
• Transform > Unpivot Columns > Unpivot Other Columns
• Click and cell in the Grid - Ctrl+A to select all
• Transform > Detect Data Type
• Home > Close & Load To > Pick where you want the ouput to go.

 

[bebo021999]

Assum data is in sheet1, result is in sheet2
Right click on sheet1's name, viewcode, then paste below code into. Hit F5 to run code:

Option Explicit
Sub test()
Dim lr&, lc&, i&, j&, k&, rng, arr(1 To 10000, 1 To 5)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    rng = .Range("A1", .Cells(lr, lc)).Value
    For i = 2 To UBound(rng)
        For j = 4 To UBound(rng, 2)
            If rng(i, j) > 0 Then
                k = k + 1
                arr(k, 1) = rng(i, 1): arr(k, 2) = rng(i, 2): arr(k, 3) = rng(i, 3)
                arr(k, 4) = rng(1, j): arr(k, 5) = rng(i, j)
            End If
        Next
    Next
End With
With Sheets("Sheet2")
    .Range("A2").Resize(k, 5).Value = arr
End With
End Sub[ATTACH type="full"]84110[/ATTACH][ATTACH type="full"]84111[/ATTACH]

 

[hpo2509]

What you are doing is called an unpivot an bread and butter for Power Query

• Click anywhere in your data set
• On the menu Date > From Table/Range (see image below)
• It will ask you if "Create Table" in My Table has headers should be ticked > hit ok
• PQ will fire up
• On the right remove the Changed type step (hit the x)
• Highlight the 1st 3 columns (Name -> Manager)
• Transform > Unpivot Columns > Unpivot Other Columns
• Click and cell in the Grid - Ctrl+A to select all
• Transform > Detect Data Type
• Home > Close & Load To > Pick where you want the ouput to go.

View attachment 84108

thanks Alex, data is still in the same file so would like to have the VBA in the same file as well, tried the power query but for another source though.

 

[hpo2509]

Assum data is in sheet1, result is in sheet2
Right click on sheet1's name, viewcode, then paste below code into. Hit F5 to run code:

Option Explicit
Sub test()
Dim lr&, lc&, i&, j&, k&, rng, arr(1 To 10000, 1 To 5)
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    rng = .Range("A1", .Cells(lr, lc)).Value
    For i = 2 To UBound(rng)
        For j = 4 To UBound(rng, 2)
            If rng(i, j) > 0 Then
                k = k + 1
                arr(k, 1) = rng(i, 1): arr(k, 2) = rng(i, 2): arr(k, 3) = rng(i, 3)
                arr(k, 4) = rng(1, j): arr(k, 5) = rng(i, j)
            End If
        Next
    Next
End With
With Sheets("Sheet2")
    .Range("A2").Resize(k, 5).Value = arr
End With
End Sub[ATTACH type="full"]84110[/ATTACH][ATTACH type="full"]84111[/ATTACH]

Thanks @bebo021999 will try and let you know.