Consulting

Results 1 to 3 of 3

Thread: Transposing Excel table using VBA

  1. #1

    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.
    Capture.JPG

    '************************************************************************
    '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
    Last edited by Paul_Hossler; 07-02-2018 at 09:30 AM. Reason: Moved from 'Testing' forum for more visibility

  2. #2
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    7,192
    Location
    Moved from Testing area
    ---------------------------------------------------------------------------------------------------------------------

    Paul

    Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    7,192
    Location
    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


    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
    ---------------------------------------------------------------------------------------------------------------------

    Paul

    Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •