If value in a colum the same concatenate another colume
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 |
If value in a colum the same concatenate another colume
On Friday, August 30, 2013 5:09:58 PM UTC-7, wrote:
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 |
If value in a colum the same concatenate another colume
|
If value in a colum the same concatenate another colume
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. -- Win XP PRof SP2 / Vista Ultimate SP2 Office 2003 SP2 /2007 Ultimate SP2 |
If value in a colum the same concatenate another colume
On Saturday, August 31, 2013 10:18:56 AM UTC+1, Claus Busch wrote:
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. -- 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 |
All times are GMT +1. The time now is 06:06 PM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com