If value in a colum the same concatenate another colume

[eidde1]

Hi
This is tricky to explain so I will show the output I want below, basicallyif the same unique value is in one column I would like to concatenate values from those unique value in the existing column to create one row. Easierto demonstrate. I wonder would anyone know some macro code to achieve this..


Head1 Head2
123 joe
154 steve
123 tom
129 kate

to give


head1 head2
123 joe,tom
154 steve
129 kate

Thank you for any help

 

[Howard]

Hi

This is tricky to explain so I will show the output I want below, basically if the same unique value is in one column I would like to concatenate values from those unique value in the existing column to create one row. Easier to demonstrate. I wonder would anyone know some macro code to achieve this.





Head1 Head2

123 joe

154 steve

123 tom

129 kate



to give





head1 head2

123 joe,tom

154 steve

129 kate



Thank you for any help

Try this, From my archives, I don't recall the author.

Option Explicit

Sub Test()
Dim LRow1 As Long
Dim LRow2 As Long
Dim i As Long
Dim j As Long
Dim rngC As Range
Dim c As Range
Dim firstAddress As String
Dim myStr As String

j = 1
LRow1 = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To LRow1
If WorksheetFunction.CountIf(Range(Cells(1, 1), _
Cells(i, 1)), Cells(i, 1)) = 1 Then
Cells(j, 3) = Cells(i, 1)
j = j + 1
End If
Next

LRow2 = Cells(Rows.Count, 3).End(xlUp).Row
For Each rngC In Range("C1:C" & LRow2)
myStr = ""
With Range("A1:A" & LRow1)
Set c = .Find(rngC, after:=Cells(LRow1, 1), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
myStr = myStr & c.Offset(0, 1) & ", "
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
rngC.Offset(0, 1) = Left(myStr, Len(myStr) - 2)
End If
End With
Next
End Sub

 

[Claus Busch]

Hi,

Am Fri, 30 Aug 2013 17:09:58 -0700 (PDT) schrieb (e-mail address removed):

Head1 Head2
123 joe
154 steve
123 tom
129 kate

to give

head1 head2
123 joe,tom
154 steve
129 kate

to do it in place try:

Sub Test()
Dim rngC As Range
Dim c As Range
Dim LRow As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each rngC In Range("A2:A" & LRow)
Do
With Range(Cells(rngC.Row + 1, 1), Cells(LRow, 1))
Set c = .Find(rngC, Cells(LRow, 1), xlValues).Offset(, 1)
If Not c Is Nothing Then
rngC.Offset(, 1) = rngC.Offset(, 1) & ", " & c
Rows(c.Row).Delete
LRow = LRow - 1
End If
End With
Loop While WorksheetFunction.CountIf( _
Range(Cells(rngC.Row, 1), Cells(LRow, 1)), rngC) > 1
Next
End Sub


Regards
Claus B.

 

[Claus Busch]

Hi again,

Am Sat, 31 Aug 2013 11:11:18 +0200 schrieb Claus Busch:

to do it in place try:

Sub Test()

with the code in last answer you get an error if a number exists only
one time.
Better try:

Sub Test()
Dim rngC As Range
Dim c As Range
Dim LRow As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row
For Each rngC In Range("A2:A" & LRow)
If WorksheetFunction.CountIf(Range(Cells(rngC.Row, 1), _
Cells(LRow, 1)), rngC) > 1 Then
Do
With Range(Cells(rngC.Row + 1, 1), Cells(LRow, 1))
Set c = .Find(rngC, Cells(LRow, 1), xlValues).Offset(, 1)
If Not c Is Nothing Then
rngC.Offset(, 1) = rngC.Offset(, 1) & ", " & c
Rows(c.Row).Delete
LRow = LRow - 1
End If
End With
Loop While WorksheetFunction.CountIf( _
Range(Cells(rngC.Row, 1), Cells(LRow, 1)), rngC) > 1
End If
Next
End Sub


Regards
Claus B.

 

[eidde1]

Hi again,



Am Sat, 31 Aug 2013 11:11:18 +0200 schrieb Claus Busch:






with the code in last answer you get an error if a number exists only

one time.

Better try:



Sub Test()

Dim rngC As Range

Dim c As Range

Dim LRow As Long



LRow = Cells(Rows.Count, 1).End(xlUp).Row

For Each rngC In Range("A2:A" & LRow)

If WorksheetFunction.CountIf(Range(Cells(rngC.Row, 1), _

Cells(LRow, 1)), rngC) > 1 Then

Do

With Range(Cells(rngC.Row + 1, 1), Cells(LRow, 1))

Set c = .Find(rngC, Cells(LRow, 1), xlValues).Offset(, 1)

If Not c Is Nothing Then

rngC.Offset(, 1) = rngC.Offset(, 1) & ", " & c

Rows(c.Row).Delete

LRow = LRow - 1

End If

End With

Loop While WorksheetFunction.CountIf( _

Range(Cells(rngC.Row, 1), Cells(LRow, 1)), rngC) > 1

End If

Next

End Sub





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2

Thanks Howard, it works perfect but I might use Claus solution as it it works in place and saves a few lines of code for me.

Great answers guys many thanks