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

Transpose or macro to convert multiple rows to Column

IKHAN

Member
Hi Everyone, I' ve been searching threads to convert multiple rows with same items to single column Header and get subsequent data related to items.Have huge data in multiple rows and column, Kindly provide a solution to convert multiple same data rows into columns as below.
Have attached sample file

Original data:


Fruit(ColA) - Location(ColD)
Apple - Texas5
Apple - cali.6
Apple - Ohio.new
Orange - buffalo
Apple - Texas7
orange - Japan
Orange - SA
Grapes - India
Orange - Srilanka
grapes - Texas4
Grapes - Washington
Blank - seatle

Desired Output reqd :
Apple(ColA) - Orange(ColB) - Grapes(ColC) - Blank(ColD)
Texas5 - buffalo - India - Seatle
cali.6 - Japan - Texas4
Ohio.new - SA - Washington
Texas7 - Srilanka
 

Attachments

  • Test.xlsx
    9.2 KB · Views: 32
Hi,

How huge is your input data set(Rows * Columns). Reason I am asking this is because we can use both VBA as well Formulae to achieve the result.

But if data set isn't really too big for formulae to digest easily we can use that option otherwise we should go for VBA solution.
 
A question. Will there be duplicate values for Col D in actual data? Or will it be list of unique like sample data?
 
Hi !

According to attachment :​
Code:
Sub Demo1()
        Application.ScreenUpdating = False
With Sheet1.Cells(1).CurrentRegion.Resize(, 4).Rows
    VA = Application.Index(.Value, Evaluate("ROW(2:" & .Count & ")"), [{1,4}])
End With
With Sheet2
        .UsedRange.Clear
    For R& = 1 To UBound(VA)
         V = Application.Match(VA(R, 1), .UsedRange.Rows(1), 0)
        If IsError(V) Then C& = C& + 1: V = C: .Cells(C).Value = VA(R, 1)
        .Cells(.Rows.Count, V).End(xlUp)(2).Value = VA(R, 2)
    Next
        Application.Goto .Cells(1), True
End With
        Application.ScreenUpdating = True
End Sub
Do you like it ? So thanks to click on bottom right Like !
 
Using Dictionary method.
Code:
Public Sub ProcessData()
Dim varInput, varKey, varOut
Dim objDict As Object
Dim i As Long
'\\initial prep
varInput = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row).Value
Set objDict = CreateObject("Scripting.Dictionary")
objDict.Comparemode = vbTextCompare
'\\load in dictionary
For i = LBound(varInput) To UBound(varInput)
    If objDict.Exists(varInput(i, 1)) Then
        objDict.Item(varInput(i, 1)) = objDict.Item(varInput(i, 1)) & ";" & varInput(i, 4)
    Else
        objDict.Add varInput(i, 1), varInput(i, 4)
    End If
Next i
'\\put it in destination sheet
Sheets(2).UsedRange.Clear
i = 1
For Each varKey In objDict.Keys
    Sheets(2).Cells(1, i).Value = varKey
    varOut = Split(objDict.Item(varKey), ";")
    Sheets(2).Cells(2, i).Resize(UBound(varOut) + 1, 1).Value = Application.Transpose(varOut)
    i = i + 1
Next
End Sub
 
No loop for relatively small amount of data.
Code:
Sub test()
    Dim x, myMax As Long
    With Cells(1).CurrentRegion.Resize(, 4)
        With .Offset(1).Columns(1)
            x = Filter(.Parent.Evaluate("transpose(if(countif(offset(" & .Address & ",,,row(1:" & .Rows.Count & _
                        "))," & .Address & ")=1," & .Address & ",char(2)))"), Chr(2), 0)
            myMax = .Parent.Evaluate("max(countif(" & .Address & "," & .Address & "))")
        End With
        [g1].Resize(, UBound(x) + 1).Value = x
        [g2].FormulaArray = "=iferror(index(" & .Address & ",small(if(" & .Columns(1).Address & _
                        "=g$1,row(" & .Address & ")),row(a1)),4),"""")"
        [g2].Resize(, UBound(x) + 1).FillRight
        [g2].Resize(myMax, UBound(x) + 1).FillDown
        [g1].CurrentRegion.Value = [g1].CurrentRegion.Value
    End With
End Sub
 
shrivallabha, another Dictionary way without Transpose :​
Code:
Sub Demo0()
    Application.ScreenUpdating = False
With Sheet1.Cells(1).CurrentRegion.Resize(, 4).Rows
    VA = Application.Index(.Value, Evaluate("ROW(2:" & .Count & ")"), [{1,4}])
End With
With CreateObject("Scripting.Dictionary")
    .Comparemode = vbTextCompare
For R& = 1 To UBound(VA)
 If .Exists(VA(R, 1)) Then .Item(VA(R, 1)) = .Item(VA(R, 1)) & ";""" & VA(R, 2) & """" _
                      Else .Add VA(R, 1), "{""" & VA(R, 1) & """;""" & VA(R, 2) & """"
Next
    Sheet2.UsedRange.Clear
For R = 1 To .Count
   VA = Evaluate(.Items()(R - 1) & "}")
    Sheet2.Cells(R).Resize(UBound(VA)).Value = VA
Next
    .RemoveAll
End With
    Application.Goto Sheet2.Cells(1), True
    Application.ScreenUpdating = True
End Sub
 
shrivallabha, another Dictionary way without Transpose :​
Code:
Sub Demo0()
    Application.ScreenUpdating = False
With Sheet1.Cells(1).CurrentRegion.Resize(, 4).Rows
    VA = Application.Index(.Value, Evaluate("ROW(2:" & .Count & ")"), [{1,4}])
End With
With CreateObject("Scripting.Dictionary")
    .Comparemode = vbTextCompare
For R& = 1 To UBound(VA)
If .Exists(VA(R, 1)) Then .Item(VA(R, 1)) = .Item(VA(R, 1)) & ";""" & VA(R, 2) & """" _
                      Else .Add VA(R, 1), "{""" & VA(R, 1) & """;""" & VA(R, 2) & """"
Next
    Sheet2.UsedRange.Clear
For R = 1 To .Count
   VA = Evaluate(.Items()(R - 1) & "}")
    Sheet2.Cells(R).Resize(UBound(VA)).Value = VA
Next
    .RemoveAll
End With
    Application.Goto Sheet2.Cells(1), True
    Application.ScreenUpdating = True
End Sub
That's clever use of Evaluate :cool:
 
Thanks for the replies..All above codes work but they are all case sensitive.

If any item Colum A is typed as Grapes or grapes , Its creating new column.
 
Thanks for the replies..All above codes work but they are all case sensitive.

If any item Colum A is typed as Grapes or grapes , Its creating new column.
That'd not happen with the code I have posted. Your data has different cases of "Grapes". And it gives desired result.
AppleOrangeGrapesBlank
Texas5buffaloIndiaseatle
cali.6JapanTexas4
Ohio.newSAWashington
Texas7Srilanka
 
Back
Top