indi visual
Member
I am looking for a help with a code that will find duplicate entries in column D, and then clear (not delete) the contents of the entire row.
I almost have it with the code beneath, but I think I went wrong somewhere at the end.
[pre]<br />
Sub RemoveDuplicates()<br />
Dim rConstRange As Range, rFormRange As Range<br />
Dim rAllRange As Range, rCell As Range<br />
Dim iCount As Long<br />
Dim strAdd As String<br />
Range("D10:D1000".Select<br />
On Error Resume Next<br />
Set rAllRange = Selection<br />
If WorksheetFunction.CountA(rAllRange) < 2 Then<br />
MsgBox "You selection is not valid", vbInformation<br />
On Error GoTo 0<br />
Exit Sub<br />
End If<br />
Set rConstRange = rAllRange.SpecialCells(xlCellTypeConstants)<br />
Set rFormRange = rAllRange.SpecialCells(xlCellTypeFormulas)<br />
If Not rConstRange Is Nothing And Not rFormRange Is Nothing Then<br />
Set rAllRange = Union(rConstRange, rFormRange)<br />
ElseIf Not rConstRange Is Nothing Then<br />
Set rAllRange = rConstRange<br />
ElseIf Not rFormRange Is Nothing Then<br />
Set rAllRange = rFormRange<br />
Else<br />
MsgBox "No Dupilcate Entries Found", vbInformation<br />
On Error GoTo 0<br />
Exit Sub<br />
End If<br />
Application.Calculation = xlCalculationManual<br />
For Each rCell In rAllRange<br />
strAdd = rCell.Address<br />
strAdd = rAllRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, _<br />
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _<br />
MatchCase:=False).Address<br />
If strAdd <> rCell.Address Then<br />
ActiveRow.Select<br />
ActiveRow.ClearContents<br />
End If<br />
Next rCell<br />
Application.Calculation = xlCalculationAutomatic<br />
On Error GoTo 0<br />
End Sub<br />
[/pre]
I almost have it with the code beneath, but I think I went wrong somewhere at the end.
[pre]<br />
Sub RemoveDuplicates()<br />
Dim rConstRange As Range, rFormRange As Range<br />
Dim rAllRange As Range, rCell As Range<br />
Dim iCount As Long<br />
Dim strAdd As String<br />
Range("D10:D1000".Select<br />
On Error Resume Next<br />
Set rAllRange = Selection<br />
If WorksheetFunction.CountA(rAllRange) < 2 Then<br />
MsgBox "You selection is not valid", vbInformation<br />
On Error GoTo 0<br />
Exit Sub<br />
End If<br />
Set rConstRange = rAllRange.SpecialCells(xlCellTypeConstants)<br />
Set rFormRange = rAllRange.SpecialCells(xlCellTypeFormulas)<br />
If Not rConstRange Is Nothing And Not rFormRange Is Nothing Then<br />
Set rAllRange = Union(rConstRange, rFormRange)<br />
ElseIf Not rConstRange Is Nothing Then<br />
Set rAllRange = rConstRange<br />
ElseIf Not rFormRange Is Nothing Then<br />
Set rAllRange = rFormRange<br />
Else<br />
MsgBox "No Dupilcate Entries Found", vbInformation<br />
On Error GoTo 0<br />
Exit Sub<br />
End If<br />
Application.Calculation = xlCalculationManual<br />
For Each rCell In rAllRange<br />
strAdd = rCell.Address<br />
strAdd = rAllRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, _<br />
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _<br />
MatchCase:=False).Address<br />
If strAdd <> rCell.Address Then<br />
ActiveRow.Select<br />
ActiveRow.ClearContents<br />
End If<br />
Next rCell<br />
Application.Calculation = xlCalculationAutomatic<br />
On Error GoTo 0<br />
End Sub<br />
[/pre]