Try this for finding and deleting duplicates!

Sub RemoveDuplicateCells()
Dim Myrange As Range
Dim C As Range
Dim DelRange As Range
Dim FindRange
Set Myrange = Intersect(ActiveSheet.UsedRange, Columns("D"))
If Myrange Is Nothing Then Exit Sub
Application.ScreenUpdating = False
FindRange = Array("D", "D", "D")
For Each elem In FindRange
Set C = Myrange.Find(elem, Myrange.Cells(1), xlValues, xlPart)
If Not C Is Nothing Then
If DelRange Is Nothing Then Set DelRange = Rows(C.Row)
firstaddress = C.Address
Do
Set C = Myrange.FindNext(C)
Set DelRange = Union(DelRange, Rows(C.Row))
Loop While firstaddress < C.Address
End If
Next
Application.ScreenUpdating = True
If DelRange Is Nothing Then Exit Sub
DelRange.Delete shift:=xlUp
End Sub


Public Sub Delete_In_H()
Const MyColumn As Integer = 4
Dim lngRow As Integer
Dim maxRow As Integer

maxRow = Cells(ActiveSheet.Rows.Count, MyColumn).End(xlUp).Row

For lngRow = maxRow To 1 Step -1
If Cells(lngRow, MyColumn).Value = "D" Then

Cells(lngRow, 3).Delete
Cells(lngRow, 4).Delete
Cells(lngRow, 5).Delete
Cells(lngRow, 6).Delete
Cells(lngRow, 7).Delete

End If
Next lngRow
End Sub



Hope this helps!

Simo

--
Message posted from http://www.ExcelForum.com