VBA or formula to transpose/re-arranging data in columns

[rozek]

Hello. Appreciate any help on this transpose/re-arranging of columns. What I wanted to achieved is straight forward but seems difficult to do.

I wanted to re arrange this dataset below:

Book1
	A	B	C	D
1		SALARY
2	DATE	NAME1	NAME2	NAME3
3	1/1/2021	10	1	100
4	2/1/2021	20	2	200
5	3/1/2021	30	3	300
6	4/1/2021	40	4	400
7	5/1/2021	50	5	500
8	6/1/2021	60	6	600
9	7/1/2021	70	7	700
10	8/1/2021	80	8	800
11	9/1/2021	90	9	900
12	10/1/2021	100	10	1000
Sheet1 (2)

To be in this arrangement

Book1
	A	B	C
1	NAME	DATE	SALARY
2	NAME1	1/1/2021	10
3	NAME1	2/1/2021	20
4	NAME1	3/1/2021	30
5	NAME1	4/1/2021	40
6	NAME1	5/1/2021	50
7	NAME1	6/1/2021	60
8	NAME1	7/1/2021	70
9	NAME1	8/1/2021	80
10	NAME1	9/1/2021	90
11	NAME1	10/1/2021	100
12	NAME2	1/1/2021	1
13	NAME2	2/1/2021	2
14	NAME2	3/1/2021	3
15	NAME2	4/1/2021	4
16	NAME2	5/1/2021	5
17	NAME2	6/1/2021	6
18	NAME2	7/1/2021	7
19	NAME2	8/1/2021	8
20	NAME2	9/1/2021	9
21	NAME2	10/1/2021	10
22	NAME3	1/1/2021	100
23	NAME3	2/1/2021	200
24	NAME3	3/1/2021	300
25	NAME3	4/1/2021	400
26	NAME3	5/1/2021	500
27	NAME3	6/1/2021	600
28	NAME3	7/1/2021	700
29	NAME3	8/1/2021	800
30	NAME3	9/1/2021	900
31	NAME3	10/1/2021	1000
Sheet1 (2)

Any help is much appreciated. Thank you.

 

[Peter_SSs]

Try this then. I assume columns F:H are free to receive the results.

Sub Rearrange()
  Dim addrA As String, addr2 As String, addrData
  
  With Range("B3", Range("A2").End(xlToRight).End(xlDown))
    addrA = .Columns(0).Address(1, 1, xlR1C1)
    addr2 = .Rows(0).Address(1, 1, xlR1C1)
    addrData = .Address(1, 1, xlR1C1)
  End With
  Range("F2:H2").Value = Array("NAME", "DATE", "SALARY")
  Range("F3").Formula2R1C1 = Replace(Replace(Replace( _
      "=LET(rws,ROWS(#),cols,COLUMNS(%),c_1,INDEX(%,INT(SEQUENCE(rws*cols,,rws)/rws))," _
        & "c_2,INDEX(#,MOD(SEQUENCE(rws*cols,,0),rws)+1),CHOOSE({1,2,3},c_1,c_2," _
        & "INDEX(@,MATCH(c_2,#,0),MATCH(c_1,%,0))))", "#", addrA), "%", addr2), "@", addrData)
  Columns("G").NumberFormat = "d/m/yyyy"
End Sub

 

[rozek]

Try this then. I assume columns F:H are free to receive the results.

Sub Rearrange()
  Dim addrA As String, addr2 As String, addrData
 
  With Range("B3", Range("A2").End(xlToRight).End(xlDown))
    addrA = .Columns(0).Address(1, 1, xlR1C1)
    addr2 = .Rows(0).Address(1, 1, xlR1C1)
    addrData = .Address(1, 1, xlR1C1)
  End With
  Range("F2:H2").Value = Array("NAME", "DATE", "SALARY")
  Range("F3").Formula2R1C1 = Replace(Replace(Replace( _
      "=LET(rws,ROWS(#),cols,COLUMNS(%),c_1,INDEX(%,INT(SEQUENCE(rws*cols,,rws)/rws))," _
        & "c_2,INDEX(#,MOD(SEQUENCE(rws*cols,,0),rws)+1),CHOOSE({1,2,3},c_1,c_2," _
        & "INDEX(@,MATCH(c_2,#,0),MATCH(c_1,%,0))))", "#", addrA), "%", addr2), "@", addrData)
  Columns("G").NumberFormat = "d/m/yyyy"
End Sub

Awesome code Peter. Thank you. If I want to re-arrange it to another sheet, where should i tweak the code at.

 

[Peter_SSs]

If I want to re-arrange it to another sheet, where should i tweak the code at.

Try this. Check/edit sheet names in the code and I have assumed the results sheet does not already contain data in columns A:C.

Sub Rearrange_v2()
  Dim addrA As String, addr2 As String, addrData
  Dim wsD As Worksheet, wsR As Worksheet
  
  Set wsD = Sheets("Data")
  Set wsR = Sheets("Result")
  
  With wsD.Range("B3", wsD.Range("A2").End(xlToRight).End(xlDown))
    addrA = .Columns(0).Address(1, 1, xlR1C1, True)
    addr2 = .Rows(0).Address(1, 1, xlR1C1, True)
    addrData = .Address(1, 1, xlR1C1, True)
  End With
  With wsR
    .Range("A1:C1").Value = Array("NAME", "DATE", "SALARY")
    .Range("A2").Formula2R1C1 = Replace(Replace(Replace( _
        "=LET(rws,ROWS(#),cols,COLUMNS(%),c_1,INDEX(%,INT(SEQUENCE(rws*cols,,rws)/rws))," _
          & "c_2,INDEX(#,MOD(SEQUENCE(rws*cols,,0),rws)+1),CHOOSE({1,2,3},c_1,c_2," _
          & "INDEX(@,MATCH(c_2,#,0),MATCH(c_1,%,0))))", "#", addrA), "%", addr2), "@", addrData)
    .Columns("B").NumberFormat = "d/m/yyyy"
  End With
End Sub

 

[rozek]

Thank you. Awesome. 5 Star rating. Have a good and pleasant day ahead Peter

 

[Peter_SSs]

You're welcome. Glad it worked for you. Thanks for the follow-up.