Solved: Delete Duplicate Values only... Not rows

[C.R.]

Hello,

I am using Windows 7... Excel 2010.

I am looking for a more efficient way to Delete Duplicate Values, in cells, in specified columns.
I do not want to delete the rows in which the duplicates appear. Just keep the first instance of the value, and delete the others.

I have been using this:

[vba]
Sub DeleteDups()
Dim lastRow As Long, i As Long

Application.ScreenUpdating = False

With Sheets("Data")
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

For i = lastRow To 1 Step -1
If Application.CountIf(.Range("C1:C" & lastRow), .Range("C" & i)) > 1 Then
.Range("C" & i).ClearContents
End If
Next i
End With

Application.Screenupdating = True
End Sub

[/vba]

And adding other columns to it as needed.

But the data can be 15 or 20 K rows, and over multiple columns, it is slow. It does work though. Data keeps growing too.

Attached is a sample.


Many thanks In advance.

C.R.

[GTO]

Maybe something like:
[VBA]Option Explicit
Sub Example()
Dim rngLastCell As Range
Dim rngValues As Range
Dim aryValues As Variant

With Sheet1 '<--- Using CodeName,
'OR,
'Worksheet (Tab) name: ThisWorkbook.Worksheets ("Sheet1")

'// Find cell in last row with data. //
Set rngLastCell = RangeFound(.Range(.Cells(2, "A"), .Cells(.Rows.Count, "G")))

'// Ensure data is there. //
If rngLastCell Is Nothing Then Exit Sub
If rngLastCell.Row < 3 Then Exit Sub

'// Set a reference to the range,... //
Set rngValues = .Range(.Cells(2, "A"), .Cells(rngLastCell.Row, "G"))
End With

'// and plunk all the values into an array, before... //
aryValues = rngValues.Value

'// passing the array ByRef, where the elements can get "emmptied" if duplicate.//
StripDups aryValues, 3, 4, 5

'// Plunk the array of values back into the range.
rngValues.Value = aryValues
End Sub

Function StripDups(ValuesPassed, ParamArray WhichColumns() As Variant)
Dim DIC As Object ' Dictionary
Dim IndexParam As Long
Dim IndexArrayRow As Long

'// Set a reference to a created dictionary. //
Set DIC = CreateObject("Scripting.Dictionary")

'// Loop through each column selected to work against in the ParamArray //
For IndexParam = LBound(WhichColumns) To UBound(WhichColumns)
'// After the first loop, we'll want to dump whatever is in the dictionary. //
If DIC.Count > 0 Then DIC.RemoveAll
'// Run through the 'rows' in whatever 'column' of the array that we are in. //
For IndexArrayRow = LBound(ValuesPassed, 1) To UBound(ValuesPassed, 1)
'// If a key does not exist for the value, add an item/key. The item can //
'// just stay empty, we are interested in the key only, for .Exists. //
If Not DIC.Exists(ValuesPassed(IndexArrayRow, WhichColumns(IndexParam))) Then
DIC.Item(ValuesPassed(IndexArrayRow, WhichColumns(IndexParam))) = Empty
Else
'// Else erase the value in the array. //
ValuesPassed(IndexArrayRow, WhichColumns(IndexParam)) = vbNullString
End If
Next
Next
End Function

Function RangeFound(SearchRange As Range, _
Optional ByVal FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function[/VBA]
Hope that helps,

Mark

[mohanvijay]

Try this

[vba]

Sub Delete_Dup()
Dim L_Rw As Long
With ThisWorkbook.Sheets(1)
L_Rw = .Cells(Rows.Count, 3).End(xlUp).Row

.Range("i2").Value = "=IF(COUNTIF($C$1:$C$" & L_Rw & ",C2)>1," & _
"IF(MATCH(C2,$C$1:$C$" & L_Rw & ",0)<>ROW(C2),1,""Cor""),""Cor"")"
.Range("i2").Copy .Range("i2:i" & L_Rw)

.Range("i2:i" & L_Rw).SpecialCells(xlCellTypeFormulas, 1).Offset(, -6).ClearContents
.Range("i2:i" & L_Rw).ClearContents

'try the same to rest two colums


End With
End Sub
[/vba]

[mohanvijay]

If the column "Line Item" is unique for the "Invoice #" then change the formula like below

[vba]

.Range("i2").Value = "=IF(F2=1,""Y"",1)"

[/vba]

[Bob Phillips]

Do the values have to be deleted, could they just be hidden?

If so, you could apply conditional formatting with a white font colour to the cells. Select C2:E20, and setup CF with a formula of

=COUNTIF(C$1:C1,C2)>0

and Format the font colour to white.

This way,the values are still there if you want to use them in a formula, just show more cleanly.

[C.R.]

All,

I am just waking up, and, I am exited to try these solutions when I get into the office today. xld... Conditional formatting never even crossed my mind. Mark and monhanvijay... thank you very much for your solutions. I will test them in a couple hours. I've been lurking here for a while, but this was my first post. This place is great!

Best Regards,

Kevin

[snb]

I think this suffices:

[vba]Sub snb()
[sheet1!C1:C40] = [if(countif(offset(sheet1!C1,,,row(C1:C40)),sheet!C1:C40)=1,sheet1!C1:C40,"" )]
End Sub[/vba]

[dimitar_bul]

Sub DeleteDups(ByVal ColToManage as Integer)
Dim lastRow As Long, i As Long

Application.ScreenUpdating = False
With Sheets("Data")
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
Sheets("Data").Activate
For i = lastRow to 2 Step -1
If Cells(i,ColToManage).Value = Cells(i-1,ColToManage).Value Then
Cells(i,ColToManage).Value=""
End If
Next i

Application.Screenupdating = True

End Sub

For each of other columns Change ColToManage

[dimitar_bul]

[VBA][/VBA]
.............. For i = lastRow To 2 Step -1 If Cells(i,"C")= Cells(i-,"C") Then Cells(i,"C").Value="" End If Next i
..............

[C.R.]

Thank you everyone.
I have more solutions than I ever needed.
So much to learn.

Kevin