• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Rearranging column of table to rows

C

callao2908

Member
Good afternoon, excuse my poor English, I´m using a translator. I need macro or functions to move from a vertical to a horizontal position table shown

The vertical board has a total of 30 columns and more than 300,000 rows

Thank you
 

Attachments

  • Chan_jgbh.xlsx
    11.1 KB · Views: 6
The expected output is not completely clear ..
Names would be in first column only or they will be populated in different columns and if so what is the logic?
 
Hello,

Here's a suggestion for you.

Code: 
Sub TransposeData()
  Dim ar
  Dim Dic, a, b, e
  Dim i As Long, str As String
 
  Set Dic = CreateObject("Scripting.dictionary")
  ar = Range("A4").CurrentRegion.Value        'Store values in array
 
  '/ Optional - to sort array on Status_Age
  ReDim Preserve ar(1 To UBound(ar, 1), 1 To UBound(ar, 2) + 1) 'Add column to array
  For i = 2 To UBound(ar, 1)
      ar(i, 4) = ar(i, 2) & ar(i, 3)  'merge status and age
  Next i
  Sort2DVert ar, 4, "A", 2  'Sort on Status_Age
  '\
 
  '/ Add infor in dictionary
  For i = 2 To UBound(ar, 1)
      str = ar(i, 2) & Chr(2) & ar(i, 3)
      If Not Dic.exists(str) Then
        Dic.Add str, ar(i, 1)
      Else
        Dic(str) = Dic(str) & Chr(2) & ar(i, 1)
      End If
  Next i
 
  '/Output results
  a = Dic.keys
  b = Dic.items
  With Range("E2")
      .CurrentRegion.ClearContents
      .Value = "Status"
      .Offset(1, 0).Value = "Age"
      For i = 0 To Dic.Count - 1
        .Offset(0, i + 1) = Split(a(i), Chr(2))(0)
        .Offset(1, i + 1) = Split(a(i), Chr(2))(1)
        e = Split(b(i), Chr(2))
        .Offset(2, i + 1).Resize(UBound(e) + 1, 1) = Application.Transpose(e)
      Next i
  End With
     
End Sub
Public Sub Sort2DVert(avArray As Variant, iKey As Integer, sOrder As String, Optional iLow1, Optional iHigh1)
    Dim iLow2 As Long, iHigh2 As Long, i As Long
    Dim vItem1, vItem2 As Variant

    On Error GoTo PtrExit
    If IsMissing(iLow1) Then iLow1 = LBound(avArray)
    If IsMissing(iHigh1) Then iHigh1 = UBound(avArray)
    iLow2 = iLow1: iHigh2 = iHigh1
    vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)

    'Loop for all the items in the array between the extremes
    Do While iLow2 < iHigh2
        If sOrder = "A" Then
            Do While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1: iLow2 = iLow2 + 1: Loop
            Do While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1: iHigh2 = iHigh2 - 1: Loop
        Else
            Do While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1: iLow2 = iLow2 + 1: Loop
            Do While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1: iHigh2 = iHigh2 - 1: Loop
        End If

        If iLow2 < iHigh2 Then
            For i = LBound(avArray, 2) To UBound(avArray, 2)
                vItem2 = avArray(iLow2, i)
                avArray(iLow2, i) = avArray(iHigh2, i)
                avArray(iHigh2, i) = vItem2
            Next
        End If
        If iLow2 <= iHigh2 Then
            iLow2 = iLow2 + 1
            iHigh2 = iHigh2 - 1
        End If
    Loop

    If iHigh2 > iLow1 Then Sort2DVert avArray, iKey, sOrder, iLow1, iHigh2
    If iLow2 < iHigh1 Then Sort2DVert avArray, iKey, sOrder, iLow2, iHigh1

PtrExit:
End Sub
 
YasserKhalil said:
The expected output is not completely clear ..
Names would be in first column only or they will be populated in different columns and if so what is the logic?
Click to expand...
Yes, it is that they are only examples. You can try the same person or it could be another
Thanks for your time, I hope your answer
Jorge
 
GCExcel said:
Hello,

Here's a suggestion for you.

Code: 
Sub TransposeData()
  Dim ar
  Dim Dic, a, b, e
  Dim i As Long, str As String

  Set Dic = CreateObject("Scripting.dictionary")
  ar = Range("A4").CurrentRegion.Value        'Store values in array

  '/ Optional - to sort array on Status_Age
  ReDim Preserve ar(1 To UBound(ar, 1), 1 To UBound(ar, 2) + 1) 'Add column to array
  For i = 2 To UBound(ar, 1)
      ar(i, 4) = ar(i, 2) & ar(i, 3)  'merge status and age
  Next i
  Sort2DVert ar, 4, "A", 2  'Sort on Status_Age
  '\

  '/ Add infor in dictionary
  For i = 2 To UBound(ar, 1)
      str = ar(i, 2) & Chr(2) & ar(i, 3)
      If Not Dic.exists(str) Then
        Dic.Add str, ar(i, 1)
      Else
        Dic(str) = Dic(str) & Chr(2) & ar(i, 1)
      End If
  Next i

  '/Output results
  a = Dic.keys
  b = Dic.items
  With Range("E2")
      .CurrentRegion.ClearContents
      .Value = "Status"
      .Offset(1, 0).Value = "Age"
      For i = 0 To Dic.Count - 1
        .Offset(0, i + 1) = Split(a(i), Chr(2))(0)
        .Offset(1, i + 1) = Split(a(i), Chr(2))(1)
        e = Split(b(i), Chr(2))
        .Offset(2, i + 1).Resize(UBound(e) + 1, 1) = Application.Transpose(e)
      Next i
  End With
    
End Sub
Public Sub Sort2DVert(avArray As Variant, iKey As Integer, sOrder As String, Optional iLow1, Optional iHigh1)
    Dim iLow2 As Long, iHigh2 As Long, i As Long
    Dim vItem1, vItem2 As Variant

    On Error GoTo PtrExit
    If IsMissing(iLow1) Then iLow1 = LBound(avArray)
    If IsMissing(iHigh1) Then iHigh1 = UBound(avArray)
    iLow2 = iLow1: iHigh2 = iHigh1
    vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)

    'Loop for all the items in the array between the extremes
    Do While iLow2 < iHigh2
        If sOrder = "A" Then
            Do While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1: iLow2 = iLow2 + 1: Loop
            Do While avArray(iHigh2, iKey) > vItem1 And iHigh2 > iLow1: iHigh2 = iHigh2 - 1: Loop
        Else
            Do While avArray(iLow2, iKey) > vItem1 And iLow2 < iHigh1: iLow2 = iLow2 + 1: Loop
            Do While avArray(iHigh2, iKey) < vItem1 And iHigh2 > iLow1: iHigh2 = iHigh2 - 1: Loop
        End If

        If iLow2 < iHigh2 Then
            For i = LBound(avArray, 2) To UBound(avArray, 2)
                vItem2 = avArray(iLow2, i)
                avArray(iLow2, i) = avArray(iHigh2, i)
                avArray(iHigh2, i) = vItem2
            Next
        End If
        If iLow2 <= iHigh2 Then
            iLow2 = iLow2 + 1
            iHigh2 = iHigh2 - 1
        End If
    Loop

    If iHigh2 > iLow1 Then Sort2DVert avArray, iKey, sOrder, iLow1, iHigh2
    If iLow2 < iHigh1 Then Sort2DVert avArray, iKey, sOrder, iLow2, iHigh1

PtrExit:
End Sub
Click to expand...

GCExcel Thanks for your prompt attention. I will try in my file with actual data
 
Try
Code: 
Sub test()
    Dim a, i As Long, ii As Long, t As Long, e, v, SL As Object
    Set SL = CreateObject("System.Collections.SortedList")
    a = [a4].CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not SL.Contains(a(i, 2)) Then
            Set SL(a(i, 2)) = CreateObject("System.Collections.SortedList")
        End If
        If Not SL(a(i, 2)).Contains(a(i, 3)) Then
            Set SL(a(i, 2))(a(i, 3)) = CreateObject("Scripting.Dictionary")
        End If
        SL(a(i, 2))(a(i, 3))(a(i, 1)) = Trim$(SL(a(i, 2))(a(i, 3))(a(i, 1)) & " " & i)
    Next
    ReDim a(1 To UBound(a, 1) + 3, 1 To SL.Count * UBound(a, 1))
    a(1, 1) = "Statue": a(2, 1) = "Age": t = 1
    For i = 0 To SL.Count - 1
        For ii = 0 To SL.GetByIndex(i).Count - 1
            t = t + 1
            a(1, t) = SL.GetKey(i)
            a(2, t) = SL.GetByIndex(i).GetKey(ii)
            For Each e In SL.GetByIndex(i).GetByIndex(ii).keys
                For Each v In Split(SL.GetByIndex(i).GetByIndex(ii)(e))
                    a(v + 2, t) = e
            Next v, e
    Next ii, i
    With [e2].Resize(UBound(a, 1), t)
        .CurrentRegion.EntireColumn.ClearContents
        .Value = a
    End With
End Sub
 

Attachments

  • Chan_jgbh with code.xlsm
    20.1 KB · Views: 9
What does below codes are doing here ?
Code: 
  Dim SL As Object
  Set SL = CreateObject("System.Collections.SortedList")
How should a vba beginner should use it?

Kindly guide. Thanks in advance.
 
1) Setting a reference to SortedList in .NET Framework object.

2) Works like Dictionary object, but the keys are Sorted in ascending order automatically, and has restrictions that dictionary doesn't have.

If you are beginner, learn Dictionary object first.
 
You must log in or register to reply here.
Back
Top