Convert vertical to horizontal on multiple columns

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Convert vertical to horizontal on multiple columns

Post by 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
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Convert vertical to horizontal on multiple columns

Post by HansV »

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

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Convert vertical to horizontal on multiple columns

Post by YasserKhalil »

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

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Convert vertical to horizontal on multiple columns

Post by HansV »

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

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Convert vertical to horizontal on multiple columns

Post by YasserKhalil »

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

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Convert vertical to horizontal on multiple columns

Post by 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
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Convert vertical to horizontal on multiple columns

Post by YasserKhalil »

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

User avatar
DocAElstein
4StarLounger
Posts: 545
Joined: 18 Jan 2022, 15:59
Location: Re-routing rivers, in Hof, Beautiful Bavaria

Re: Convert vertical to horizontal on multiple columns

Post by 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
You do not have the required permissions to view the files attached to this post.
I seriously don’t ever try to annoy. Maybe I am just the kid that missed being told about the King’s new magic suit, :(

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Convert vertical to horizontal on multiple columns

Post by YasserKhalil »

Wonderful Mr. Alan. Nice approach

User avatar
p45cal
2StarLounger
Posts: 142
Joined: 11 Jun 2012, 20:37

Re: Convert vertical to horizontal on multiple columns

Post by 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).
You do not have the required permissions to view the files attached to this post.