Sep 04 2019 03:10 PM - edited Sep 04 2019 03:37 PM
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.
Sep 04 2019 07:05 PM
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
Sep 05 2019 08:04 AM
@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:
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")
Thank you again for your help!
Sep 05 2019 09:31 AM
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