Transposing Excel table using VBA

Hi all,

I am super new to VBA and have looked at trying to fix this code on my own for a while now. I am trying to use the below code to transpose a table in excel. The table has 522 rows and 2 columns. I need it to be transposed to 522 columns and 2 rows. Thank you so much for any help.Attachment 22484

Code:

---

'************************************************************************

'The code will work like this

'1) UnPivot the data on Sheet1

'2) Insert a New Sheet called Tranposed if not available in the workbook

'3) Place the output i.e. UnPivoted data on the Transposed Sheet.

'************************************************************************

Sub UnPivotData()

    Dim wsSource As Worksheet, wsDest As Worksheet

    Dim x, y, i As Long, j As Long, n As Long

    'Assuming data is on a sheet called "Sheet1", change it if required

    Set wsSource = Sheets("Sheet1")

    x = wsSource.Cells(1).CurrentRegion.Value

    ReDim y(1 To UBound(x, 1) * UBound(x, 2), 1 To 2)

    For i = 2 To UBound(x, 1)

        For j = 2 To UBound(x, 2)

            If x(i, j) <> "" Then

                n = n + 1

                y(n, 1) = x(i, 1)

                y(n, 2) = x(i, j)

            End If

        Next

    Next

    On Error Resume Next

    Set wsDest = Sheets("Transposed")

    wsDest.Cells.Clear

    On Error GoTo 0

    If wsDest Is Nothing Then

        Sheets.Add(after:=wsSource).Name = "Transposed"

        Set wsDest = ActiveSheet

    End If

    'wsDest.Range("A1:B1").Value = Array("Number", "Deatils")

    wsDest.Range("A1").Resize(UBound(y), 550).Value = y

    wsDest.Range("A1").CurrentRegion.Borders.Color = vbBlack

    MsgBox "Data Transposed Successfully.", vbInformation, "Done!"

End Sub

---

Moved from Testing area

Wasn't clear which line was causing the error

This is still doing it with loops the way you had it, but you could use the TRANSPOSE() worksheet function with VBA, or Copy/PasteSpecial with Transpose also

Code:

---

Option Explicit
'************************************************************************
'The code will work like this
'1) UnPivot the data on Sheet1
'2) Insert a New Sheet called Tranposed if not available in the workbook
'3) Place the output i.e. UnPivoted data on the Transposed Sheet.
'************************************************************************
Sub UnPivotData()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim arySource() As Variant, aryDest() As Variant
    Dim r As Long, c As Long
 
    'Assuming data is on a sheet called "Sheet1", change it if required
    Set wsSource = Sheets("Sheet1")
    arySource = wsSource.Cells(1).CurrentRegion.Value
 
    'switch rows and columns
    ReDim aryDest(1 To UBound(arySource, 2), 1 To UBound(arySource, 1))
   
    For r = LBound(arySource, 1) To UBound(arySource, 1)
        For c = LBound(arySource, 2) To UBound(arySource, 2)
            aryDest(c, r) = arySource(r, c)
        Next c
    Next r
    On Error Resume Next
    Set wsDest = Sheets("Transposed")
    wsDest.Cells.Clear
    On Error GoTo 0
    If wsDest Is Nothing Then
        Sheets.Add(after:=wsSource).Name = "Transposed"
        Set wsDest = ActiveSheet
    End If
 
  wsDest.Range("A1").Resize(UBound(aryDest, 1), UBound(aryDest, 2)).Value = aryDest
     
  MsgBox "Data Transposed Successfully.", vbInformation, "Done!"
End Sub

---