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:



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


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:

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
Hope that helps,

Mark

[mohanvijay]

Try this



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

[mohanvijay]

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



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

[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:


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

[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]

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