How to transpose the data vertically

[akhendre88]

Hello All,

Can we transpose the data vertically. I have some data in below format.

Emp Id	Access Id	Roles
A001	abcd	READ	WRITE	DELETE

<tbody>
</tbody>

So is there any way so that I align the data in 'Roles' column like

Emp Id	Access Id	Roles
A001	abcd	READ
		WRITE
		DELETE

<tbody>
</tbody>

I was trying this,

sht.Range("C" & i) = WorksheetFunction.Transpose(.Range("C" & i))sht.Range("C" & i) = WorksheetFunction.Transpose(.Range("C" & i))

but the output was only first value i.e. READ.

Please suggest.

Thank you

 

[Michael M]

Can you give us a SLIGHTLY LARGER example to work with ???

 

[akhendre88]

Hi Michael,
Here is he some data,

Emp Id	Access Id	Roles
A001	AB01	READ	WRITE	DELETE	ADMIN	AUDITOR
A002	AB02	ADMIN	AUDITOR
A003	AB03	READ	WRITE	DELETE
A004	AB04	READ	DELETE	ADMIN	AUDITOR
A005	AB05	READ	WRITE	AUDITOR
A006	AB06	READ	WRITE	DELETE	ADMIN	AUDITOR
A007	AB07	NO ACCESS	NO ACCESS	NO ACCESS	NO ACCESS
A008	AB08	READ	WRITE	DELETE	ADMIN	AUDITOR
A009	AB09	READ	WRITE	DELETE	AUDITOR
A010	AB10	READ	WRITE	DELETE	ADMIN

<tbody>
</tbody>

 

[alansidman]

Try this:

Option Explicit


Sub trnsps()
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    Dim r1 As Long, r2 As Long
    Dim i As Long, lc As Long


    Application.ScreenUpdating = False
    s1.Range("A1:C1").Copy s2.Range("A1")
    r1 = s1.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To r1
        r2 = s2.Range("C" & Rows.Count).End(xlUp).Row
        s1.Range("A" & i & ":B" & i).Copy s2.Range("A" & r2 + 1)
        lc = Cells(i, Columns.Count).End(xlToLeft).Column
        s1.Range(Cells(i, 3), Cells(i, lc)).Copy
        s2.Range("C" & r2 + 1).PasteSpecial xlPasteAll, , , True
        Application.CutCopyMode = False
    Next i
    Application.ScreenUpdating = True
    MsgBox "complete"
End Sub

 

[Peter_SSs]

Depending on how large your data is, and just where you want the results, you might also want to test this in a copy of your workbook.

Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, ub1 As Long, ub2 As Long
  
  a = Range("A1").CurrentRegion.Value
  ub1 = UBound(a, 1)
  ub2 = UBound(a, 2)
  ReDim b(1 To ub1 * (ub2 - 2), 1 To 3)
  For i = 1 To ub1
    k = k + 1
    b(k, 1) = a(i, 1): b(k, 2) = a(i, 2): b(k, 3) = a(i, 3)
    For j = 4 To ub2
      If IsEmpty(a(i, j)) Then
        Exit For
      Else
        k = k + 1
        b(k, 3) = a(i, j)
      End If
    Next j
  Next i
  Range("A1").Offset(, UBound(a, 2) + 2).Resize(k, 3).Value = b
End Sub

For original data in columns A:G, the code above produced the results seen in columns J:L

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	Emp Id	Access Id	Roles							Emp Id	Access Id	Roles
2	A001	AB01	READ	WRITE	DELETE	ADMIN	AUDITOR			A001	AB01	READ
3	A002	AB02	ADMIN	AUDITOR								WRITE
4	A003	AB03	READ	WRITE	DELETE							DELETE
5	A004	AB04	READ	DELETE	ADMIN	AUDITOR						ADMIN
6	A005	AB05	READ	WRITE	AUDITOR							AUDITOR
7	A006	AB06	READ	WRITE	DELETE	ADMIN	AUDITOR			A002	AB02	ADMIN
8	A007	AB07	NO ACCESS	NO ACCESS	NO ACCESS	NO ACCESS						AUDITOR
9	A008	AB08	READ	WRITE	DELETE	ADMIN	AUDITOR			A003	AB03	READ
10	A009	AB09	READ	WRITE	DELETE	AUDITOR						WRITE
11	A010	AB10	READ	WRITE	DELETE	ADMIN						DELETE
12										A004	AB04	READ
13												DELETE
14												ADMIN
15												AUDITOR
16										A005	AB05	READ
17												WRITE
18												AUDITOR
19										A006	AB06	READ
20												WRITE
21												DELETE
22												ADMIN
23												AUDITOR
24										A007	AB07	NO ACCESS
25												NO ACCESS
26												NO ACCESS
27												NO ACCESS
28										A008	AB08	READ
29												WRITE
30												DELETE
31												ADMIN
32												AUDITOR
33										A009	AB09	READ
34												WRITE
35												DELETE
36												AUDITOR
37										A010	AB10	READ
38												WRITE
39												DELETE
40												ADMIN
Rearrange

 

[akhendre88]

Hi Alan,

Thank you very much for your help. However,

s1.Range(Cells(i, 3), Cells(i, lc)).Copy

this line is giving me an error "Method Range of object _Worksheet failed".

I tried from my side as well to resolve this but not able to do much with this

 

[alansidman]

unable to reproduce your error. The code works for me. My results after running the code

Emp Id	Access Id	Roles
A001	AB01	READ
		WRITE
		DELETE
		ADMIN
		AUDITOR
A002	AB02	ADMIN
		AUDITOR
A003	AB03	READ
		WRITE
		DELETE
A004	AB04	READ
		DELETE
		ADMIN
		AUDITOR
A005	AB05	READ
		WRITE
		AUDITOR
A006	AB06	READ
		WRITE
		DELETE
		ADMIN
		AUDITOR
A007	AB07	NO ACCESS
		NO ACCESS
		NO ACCESS
		NO ACCESS
A008	AB08	READ
		WRITE
		DELETE
		ADMIN
		AUDITOR
A009	AB09	READ
		WRITE
		DELETE
		AUDITOR
A010	AB10	READ
		WRITE
		DELETE
		ADMIN

<colgroup><col span="4"></colgroup><tbody>
</tbody>

 

[Peter_SSs]

I tried from my side as well to resolve this but not able to do much with this

In that case would it be worth trying the alternative code offered?

 

[Peter_SSs]

unable to reproduce your error.

Alan, try running it when Sheet1 is not the active sheet.

 

[alansidman]

Excellent Point Peter. I have changed up the code as follows:

Option Explicit


Sub trnsps()
    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    Dim r1 As Long, r2 As Long
    Dim i As Long, lc As Long


    Application.ScreenUpdating = False
    
    With s1
        .Activate
        .Range("A1:C1").Copy s2.Range("A1")
        r1 = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 2 To r1
            r2 = s2.Range("C" & Rows.Count).End(xlUp).Row
            .Range("A" & i & ":B" & i).Copy s2.Range("A" & r2 + 1)
            lc = Cells(i, Columns.Count).End(xlToLeft).Column
            .Range(Cells(i, 3), Cells(i, lc)).Copy
            s2.Range("C" & r2 + 1).PasteSpecial xlPasteAll, , , True
            Application.CutCopyMode = False
        Next i
    End With
    Application.ScreenUpdating = True
    MsgBox "complete"
End Sub

@akhendre88
To Peter's point. Have you tested his code? There is usually more than one way to solve an excel issue and this is a good example.