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 !!!

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

This sample code at John Walkenbach's site will show how to get a unique
list using a collection.

http://www.j-walk.com/ss/excel/tips/tip47.htm

You can then wrap this approach in a loop that identies when the first
column changes when you will then write you value frm the first column and
build a concatenated string for the second column from the values in the
collection - then clear the collection continue down the list

--
Regards,
Tom Ogilvy

"italia" wrote in message
ups.com...
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 !!!