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