View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
Dave Peterson Dave Peterson is offline
external usenet poster
 
Posts: 35,218
Default Concat values in two or more rows based on id and eliminateduplicates

There's an option under Data|Filter|advanced filter that you can use to extract
unique values/rows in your range.

Debra Dalgleish explains how to use it at:
http://www.contextures.com/xladvfilter01.html#FilterUR

You can use that in code, too.

Option Explicit
Sub testme()

Dim InputRng As Range
Dim wks As Worksheet
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long

Set wks = Worksheets("sheet1")

With wks
Set InputRng = .Range("a1:b" & .Cells(.Rows.Count, "A").End(xlUp).Row)

InputRng.Sort _
key1:=.Range("A1"), order1:=xlAscending, _
key2:=.Range("b1"), order2:=xlAscending, _
header:=xlYes

InputRng.AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=.Range("D1"), Unique:=True

.Range("a1:c1").EntireColumn.Delete

FirstRow = 2 'headers in row 1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
'same value
.Cells(iRow - 1, "B").Value _
= .Cells(iRow - 1, "B").Value _
& ", " & .Cells(iRow, "B").Value
.Rows(iRow).Delete
End If
Next iRow


End With

End Sub

Try this against a copy of your worksheet--it destroys the original data when it
runs.


italia wrote:

I have a spreadsheet with 2 columns and thousands of rows. The first
column is the id

Example of the data (2 columns)-

04731 CRM
04731 CRM
04731 CRM
04731 RVB
04731 RVB
25475 FRB
25475 FRB
25475 MMX
25475 MMX

Result desired (2 columns)-

04731 CRM; RVB
25475 RVB; MMX

Idea is to summarize the data and eliminate the duplicates

I am using the folloeing Code but it does not provide the desired
result-

Sub Test1()
Dim lastrow As Long
Dim i As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
i = lastrow
Do While i 1
If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
If Cells(i, 2).Value = Cells(i - 1, 2).Value Then
Cells(i, 1).EntireRow.Delete
Else
Cells(i - 1, 2).Value = Cells(i - 1, 2).Value & "; " & _
Cells(i, 2).Value
Cells(i, 1).EntireRow.Delete
End If
End If
i = i - 1
Loop
End Sub

Any help is greatly appreciated.

Thanks !!!


--

Dave Peterson