Excel Forum

Code: Select all

Sub DeleteTheDoops()
Dim RowNdx As Long
Dim RowNdx2 As Long
Dim FR As Long
FR = Range("A1:A1").End(xlDown).Row 'Freeze this row
For RowNdx = FR To 2 Step -1
    For RowNdx2 = FR To 2 Step -1
        'From what I can tell, you are interested when A, E and F are
        'equal and when C is smallest, so ...
        If RowNdx <> RowNdx2 And _
           Cells(RowNdx, "A").Value = Cells(RowNdx2, "A").Value Then
               Rows(RowNdx2).Delete
        End If
    Next RowNdx2
Next RowNdx
End Sub

Code: Select all

Sub KeepDuplicateHaft()
Dim rAll As Range
Dim i, N As Integer
Set rAll = Range("A1:A36")
N = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = True
For i = 1 To N
If (Application.CountIf(Range("A1:A" & i), Cells(i, "A")) > Application.CountIf(rAll, Cells(i, "A")) / 2) = 0 Then
Cells(i, "A") = Cells(i, "A")
Else
Cells(i, "A") = ""
End If
Next i
rAll.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Application.ScreenUpdating = True
End Sub

Code: Select all

Sub RemoveHalf()
On Error Resume Next
Dim R As Range

For Each R In Range("a1").CurrentRegion
If R = R.Offset(1) And R.Offset(-1, 3) = "" Then R.Offset(0, 3) = R
Next
Range("a1").CurrentRegion.Offset(0, 3).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub