Convert vertical to horizontal on multiple columns

[YasserKhalil]

Hello everyone

I have a code that converts a column from vertical state to horizontal (each group to be in one row)
Here's the code that deals with the second column only

Code: Select all

Sub Test()
    Dim v, a, i As Long
    v = Cells(1).CurrentRegion
    ReDim b(UBound(v) + 1)
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(v)
            a = .Item(v(i, 1))
            If IsEmpty(a) Then a = b
            a(0) = v(i, 1)
            a(UBound(a)) = a(UBound(a)) + 1
            a(a(UBound(a))) = v(i, 2)
            .Item(v(i, 1)) = a
        Next i
        Range("G2").Resize(.Count, UBound(a) - 1) = Application.Index(.Items, 0)
    End With
End Sub

The code works fine for the second column, but I need to deal with the third column too with the same idea. And as for the fourth column will be just once (in the output would be in one column)

I have attached a sample workbook with the expected output

[HansV]

If you can write that code, you should be able to complete it too...

[YasserKhalil]

It is not my code, I got it as a result of search

[HansV]

Try asking where you found it, the code is too complicated for me to analyze.

[YasserKhalil]

I didn't remember exactly as I found it in my stored files. Forget that code if it doesn't suit the case.

[HansV]

I'm not clever enough to modify the code, so here is a somewhat more cumbersome version written from scratch.

Code: Select all

Sub Test2()
    Dim m As Long
    Dim rs As String
    Dim ms As String
    Dim g As Long
    Dim n As Long
    Dim i As Long
    Dim v As Variant
    Dim s As Long
    Dim t As Long
    Application.ScreenUpdating = False
    ' Last row in column A
    m = Range("A1").End(xlDown).Row
    ' Range in column A as string
    rs = "A2:A" & m
    ' Match formula as string
    ms = "MATCH(" & rs & "," & rs & ")"
    ' Calculate max number of notes per group
    Range("G1").FormulaArray = "=SUMPRODUCT(--(" & ms & "=MODE(" & ms & ")))"
    n = Range("G1").Value
    ' Calculate number of groups
    Range("G2").FormulaArray = "=SUMPRODUCT(1/COUNTIF(" & rs & "," & rs & "))"
    g = Range("G2").Value
    ' Define output array
    ReDim o(1 To g + 1, 1 To 2 * n + 2) As Variant
    t = 1
    ' Populate first row
    o(t, 1) = "Group"
    For i = 1 To n
        o(t, i + 1) = "Amount" & i
        o(t, i + n + 1) = "Notes" & i
    Next i
    o(t, 2 * n + 2) = "Name"
    ' Input range to array
    v = Range("A1:D" & m).Value
    ' Loop through input array
    For s = 2 To m
        If v(s, 1) <> v(s - 1, 1) Then
            ' New output row
            t = t + 1
            ' Populate first and last column
            o(t, 1) = v(s, 1)
            o(t, 2 * n + 2) = v(s, 4)
            i = 1
        End If
        ' Populate amount and note columns
        i = i + 1
        o(t, i) = v(s, 2)
        o(t, n + i) = v(s, 3)
    Next s
    ' Clear range
    Range("G1:ZZ1000").ClearContents
    ' Save output to sheet
    Range("G1").Resize(g + 1, 2 * n + 2).Value = o
    Application.ScreenUpdating = True
End Sub

[YasserKhalil]

Amazing my tutor. Thank you very much for your great support all the time.

[DocAElstein]

Hi
Here’s another way. It probably isn’t any better. Just another way out of interests for comparison:

The shortened TLDR version of the Story:
We know that we can build up a single string, which we can put into the Windows Clipboard, and then .Paste out into Excel, such that it makes a typical Excel range of values ( http://www.eileenslounge.com/viewtopic. ... 41#p242941 )
( So like in a long string of the range values, we can include a vbTab, which can be thought of as a “cell wall”, and including something like vbCr & vbLf is what seems to separate rows. )

In other words: This is the final wanted output:

ThatWantedHorizontal.JPG

So to get that in the clipboard in a form to .Paste out, I need to build up a string looking pseudo like

Code: Select all

 "A" & vbTab & "10" & vbTab & "20" & vbTab & "30" & vbTab & vbTab & "N1" & vbTab & "N2" & vbTab & "N3" & vbTab & vbTab & "GroupA" & vbCr & vbLf
"B" & vbTab & "40" & vbTab & "50" & vbTab & "60" & vbTab & "70" & vbTab & "N4" & vbTab & "N5" & vbTab & "N6" & vbTab & "N7" & vbTab & "GroupB" & vbCr & vbLf
"C" & vbTab & "80" & vbTab & vbTab & vbTab & vbTab & "N8" & vbTab & vbTab & vbTab & vbTab & "GroupC" & vbCr & vbLf
"D" & vbTab & "90" & vbTab & "100" & vbTab & vbTab & vbTab & "N9" & vbTab & "N10" & vbTab & vbTab & vbTab & "GroupD" & vbCr & vbLf

So basically what I am doing is using some Do While Loopy stuff applied to the input data range, to produce that final required output data range string.

I add to that string what I need to do something similar to get the header row.

The total final string is then put in the Windows clipboard and pasted out.
This following macro seems to work on the supplied test data

Code: Select all

 '
Sub TFLDFR() '  http://www.eileenslounge.com/viewtopic.php?p=294692#p294692
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
Dim RngPlus1 As Range
 Set RngPlus1 = Ws1.Cells.Item(1).CurrentRegion.Resize(Ws1.Cells.Item(1).CurrentRegion.Rows.Count + 1, Ws1.Cells.Item(1).CurrentRegion.Columns.Count)
Dim vArr() As Variant: Let vArr() = RngPlus1.Value2
' determine the biggest group ( that maximum Amounts or Notes count )
Dim Cnt As Long, Cnt2 As Long, Mx As Long: Let Mx = 1: Let Cnt = 1
    Do
        Do
         Let Cnt = Cnt + 1
         Let Cnt2 = Cnt2 + 1
        Loop While vArr(Cnt + 1, 1) = vArr(Cnt, 1)
        If Cnt2 > Mx Then Let Mx = Cnt2
     Let Cnt2 = 0
    Loop While Cnt < UBound(vArr(), 1) - 1
' Main data range string reqiured for clipboard
 Let Cnt = 1
    Do
    Dim HrCnt As Long: Let HrCnt = 1
    Dim strClipR As String, strClipL As String: Let strClipL = strClipL & vArr(Cnt + 1, 1)
        Do
         Let Cnt = Cnt + 1
         Let HrCnt = HrCnt + 1
         Let strClipL = strClipL & vbTab & vArr(Cnt, 2)
         Let strClipR = strClipR & vbTab & vArr(Cnt, 3)
        Loop While vArr(Cnt + 1, 1) = vArr(Cnt, 1)
        Do While HrCnt < Mx + 1
         Let strClipL = strClipL & vbTab
         Let strClipR = strClipR & vbTab
         Let HrCnt = HrCnt + 1
        Loop
    
     Let strClipR = strClipR & vbTab & vArr(Cnt, 4)
    Dim strClip As String: Let strClip = strClip & strClipL & strClipR & vbCr & vbLf
    
    Let strClipL = "": strClipR = ""
    Loop While Cnt < UBound(vArr(), 1) - 1
 
' header string required for clipboard
Dim strHd As String
 Let strHd = "Group" & vbTab & Join(Evaluate("=""Amount"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab) & vbTab & Join(Evaluate("=""Note"" & COLUMN(A:" & Split(Cells(1, Mx).Address, "$")(1) & ")"), vbTab) & vbTab & "Name"
 
' full string for clipboard and paste out
Let strClip = strHd & vbCr & vbLf & strClip
Dim objDataObject As Object: Set objDataObject = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
 objDataObject.SetText Text:=strClip
 objDataObject.PutInClipboard
 Ws1.Paste Destination:=Ws1.Range("G1")

End Sub

_.____________________________

If you are interested in the full boring story, I put it here:
https://excelfox.com/forum/showthread.p ... #post16529
https://excelfox.com/forum/showthread.p ... #post16530
https://excelfox.com/forum/showthread.p ... #post16532
https://excelfox.com/forum/showthread.p ... #post16533


Alan

_.____________________________________________


ThatHorizontal.xlsm : https://app.box.com/s/aimwwh88rqgsl8cawyhwcuyz5ebhjb6z

[YasserKhalil]

Wonderful Mr. Alan. Nice approach

[p45cal]

Power Query too.
Right-click the green table and choose Refresh.
Expects to see column headers Groups and Name, the other headers inbetween can be anything (and you can add new ones if you want).