Condensing multiple outputs

Copper Contributor

I have column A with names that may repeat.

I have column B with a title related to the names in column A that can appear multiple times.

I want to be able to have multiples of the same name (from column A) collapsed into one row with the multiple titles (column B) appearing in multiple columns next to the names, with one title per column.

 

Is there any way to do this?  I've attached an example of what I would like to happen.

3 Replies

@treecamel88 

If you are open to a VBA solution, please try the following macro which will transform the data into the desired format.

In the attached, click the button called "Transform Data" on Sheet1 to get the data in the desired format.

 

Sub getNamesAndTitles()
Dim wsData  As Worksheet
Dim x       As Variant
Dim dict    As Object
Dim str()   As String
Dim it      As Variant
Dim i       As Long
Dim dlr     As Long
Dim j       As Long

Application.ScreenUpdating = False
Set wsData = Worksheets("Sheet1")   'Sheet with data
x = wsData.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")


For i = 2 To UBound(x, 1)
    If Not dict.exists(x(i, 1)) Then
        dict.Item(x(i, 1)) = x(i, 2)
    Else
        dict.Item(x(i, 1)) = dict.Item(x(i, 1)) & "_" & x(i, 2)
    End If
Next i

'Clearing the data from columns H:J before writing the transformed data
'If you want to replace the original data with the transformed data, replace H:J with A:B
wsData.Columns("H:J").ClearContents

i = 2
For Each it In dict.keys
    dlr = wsData.Range("H" & Rows.Count).End(3)(2).Row
    wsData.Range("H" & dlr).Value = it
    str = Split(dict(it), "_")
    If UBound(str) + 1 > j Then j = UBound(str) + 1
    wsData.Range("I" & dlr).Resize(, UBound(str) + 1).Value = str
Next it

'Writing the transformed data in column H and adjacent columns
'To write data in column A and it's adjacent columns, replace H1 with A1 and I1 with B1
wsData.Range("H1").Value = "Name"
wsData.Range("I1").Resize(, j).Value = "Title"

Application.ScreenUpdating = True
End Sub

@Subodh_Tiwari_sktneer Thank you for your response!

In attempting to understand your response and to be able to apply it to my actual problem, I have a couple of questions:

  1. In this section, where x = wsData.Range("A1").CurrentRegion.Value, is A1 where I can change where my input "name" column begins?

 

Application.ScreenUpdating = False
Set wsData = Worksheets("Sheet1")   'Sheet with data
x = wsData.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")

 

  • Is it possible to instead to write the transformed data to a new sheet as opposed to columns H and I?  

Thank you again for your help!

@treecamel88 

In the line...

x = wsData.Range("A1").CurrentRegion.Value

 

The code assumes that the headers are in row1 starting from A1, data starts from row2 and there is no blank column or row in between the data set. It's an easy and convenient way to store all the data into an array.

But if that's not the case in your actual file, you will have to explicitly define that which range contains the data which should be stored into an array x.

 

e.g.

Dim LR  As Long
'Assuming your data is in column G starting from row 2 where row1 being the header row
LR = wsData.Cells(Rows.Count, "G").End(xlUp).Row
x = wsData.Range("G1:H" & LR).Value

 

Yes, instead of writing the output in column H and I, you can write the output in a new sheet and for that, please try the below code...

 

Sub getNamesAndTitles()
Dim wsData  As Worksheet
Dim wsDest  As Worksheet
Dim x       As Variant
Dim dict    As Object
Dim str()   As String
Dim it      As Variant
Dim i       As Long
Dim dlr     As Long
Dim j       As Long

Application.ScreenUpdating = False
Set wsData = Worksheets("Sheet1")   'Sheet with data
x = wsData.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")


For i = 2 To UBound(x, 1)
    If Not dict.exists(x(i, 1)) Then
        dict.Item(x(i, 1)) = x(i, 2)
    Else
        dict.Item(x(i, 1)) = dict.Item(x(i, 1)) & "_" & x(i, 2)
    End If
Next i

'Adding a destination sheet for output
Set wsDest = Worksheets.Add(after:=wsData)

'Writing data to newly added Sheet
i = 2
For Each it In dict.keys
    dlr = wsDest.Range("A" & Rows.Count).End(3)(2).Row
    wsDest.Range("A" & dlr).Value = it
    str = Split(dict(it), "_")
    If UBound(str) + 1 > j Then j = UBound(str) + 1
    wsDest.Range("B" & dlr).Resize(, UBound(str) + 1).Value = str
Next it

wsDest.Range("A1").Value = "Name"
wsDest.Range("B1").Resize(, j).Value = "Title"

Application.ScreenUpdating = True
End Sub