Solved: Macro to make duplicates to be displayed in one row

[hunsnowboard]

Hi Everyone! I have the following problem:

I have an excel file where there are two columns (Code and Name). The Code columns holds the code numbers, the Name column holds the names for the codes. There can be more than one name associated to the codes, in this case the code repeats. Here is the example:
Code Name
1111 Ronie
1111 Molly
1111 Fred
1132 Lambert
1178 Gullit
1178 Edwin
... and so on.

This table is on Sheet1. What I would like is a macro which puts the names for the codes in one column and separates them with a comma (this way the code is displayed only once in one row, and it is not repeating itself in case there are more names attached to it).
So the macro (from the table above) should create something like this (on Sheet2):
Code Name
1111 Ronie, Molly, Fred
1132 Lambert
1178 Gullit, Edwin
...and so on.

I also included a sample file with the above example.

The real/original file (which I did not attach because of privacy issues) contains more than 8000 rows and it is a bit more complicated, but if someone could help me with this example than I will be able to make it work on the original file as well! Thank you very much in advance and have a nice weekend!

[mdmackillop]

Are your codes ordered. ie all same numbers together?

[mdmackillop]

BTW I did this here a week or so ago for someone else.

[mdmackillop]

Not here, but another forum!
[vba] Option Explicit
Sub Joins()
Dim rng As Range, cel As Range
Dim i As Long, txt As String
'Filter unique records
Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E1"), Unique:=True
'Get range of numbers
Set rng = Range("E1").CurrentRegion.Columns(1)
'Loop through range
For i = rng.Cells.Count To 1 Step -1
'Find first instance of number
Set cel = rng.Find(Cells(i, 5), After:=Cells(1, 5), LookIn:=xlValues, Lookat:=xlWhole)
'Get name
txt = Cells(i, 6)

If Not i = cel.Row Then
'Append name to first occurrence of number
cel.Offset(, 1) = cel.Offset(, 1) & "; " & txt
'Delete copied data
Cells(i, 5).Resize(, 2).Delete shift:=xlUp
End If
Next
End Sub
[/vba]

[hunsnowboard]

Hi Mackillop!

Thank you for the quick reply. I'll try to make it work in the original file as well....however it is very hard for me to understand this code. Anyway thank you very much, and I will try to adapt it in the original file! Thank you!

[mdmackillop]

If you can post a sample I can tweak it to suit. The original purpose was to delete duplicates in Cols 1 & 2 as well as joining the results.

[Chris Bode]

try following codes

Private Sub mySub()
    Dim row As Integer, col As Integer
    row = 1
    col = 1
    While Sheet1.Cells(row, col).Value <> ""
        arrange Sheet1.Cells(row, col).Value, row
        row = row + 1
    Wend
End Sub

Private Sub arrange(str As String, i As Integer)
    Dim row As Integer, col As Integer
    row = i + 1
    col = 1
    
    While Sheet1.Cells(i, col).Value <> ""
        col = col + 1
    Wend
    
    While Sheet1.Cells(row, 1).Value <> ""
        If str = Sheet1.Cells(row, 1).Value Then
            
            Sheet1.Cells(i, col).Value = Sheet1.Cells(row, 2).Value
            col = col + 1
            
            Sheet1.Rows(row).Delete
            
        End If
        row = row + 1
    Wend
End Sub

[hunsnowboard]

Hi Everyone! Thank you for your help and support! I was able to implement the macro in my original file. However I have two questions regarding the madmckillop macro.
1) If the code and the number is duplicate the macro does not display twice the name, only once.
Example:
Code Name
1134 Robie
1134 Robie
1111 Johny
1111 Marcus
....

I get:
1134 Robie
1111 Johny; Marcus
Could you make the macro to work like this:
1134 Robie; Robie
1111 Johny; Marcus


2) In some case there are some blank rows for some codes... in that case the results looks like this: 1115 ; John; Carrie
Is there a macro which deletes the ";" character if the cells begins with ";"?

Thank you in advance!

[mdmackillop]

[VBA]Option Explicit
Sub Joins()
Dim rng As Range, cel As Range
Dim i As Long, txt As String
Range("E:F").ClearContents
'copy data
Range("A1").CurrentRegion.Copy Range("E1")
'Get range of numbers
Set rng = Range("E1").CurrentRegion.Columns(1)
'Loop through range
For i = rng.Cells.Count To 1 Step -1
'Find first instance of number
Set cel = rng.Find(Cells(i, 5), After:=Cells(1, 5), LookIn:=xlValues, Lookat:=xlWhole)
'Get name
txt = Cells(i, 6)

If Not i = cel.Row Then
'Append name to first occurrence of number
If txt <> "" Then
cel.Offset(, 1) = cel.Offset(, 1) & "; " & txt
End If
'Delete copied data
Cells(i, 5).Resize(, 2).Delete shift:=xlUp
End If

'Lose initial ;
If Left(cel.Offset(, 1), 1) = ";" Then
cel.Offset(, 1) = Right(cel.Offset(, 1), Len(cel.Offset(, 1)) - 1)
End If
Next
End Sub[/VBA]

[hunsnowboard]

Thank you Mdmackillop it is working great! Can I use this command for removing cells beginnig with unwanted space characters as well? I just need to substitute the ";" character with " " right?

[mdmackillop]

Simpler to use Trim
cel.Offset(, 1) = Trim(cel.Offset(, 1))

[hunsnowboard]

Thank you very much Mdmackillop! It is working very good! Thank you!