Try
Code:Option Explicit Sub kTest() Dim d, i As Long, c As String, a As String, r As Range Set r = Range("a1").CurrentRegion.Resize(, 15) d = r.Value2 Application.ScreenUpdating = 0 With CreateObject("scripting.dictionary") .comparemode = 1 For i = UBound(d, 1) To 2 Step -1 c = d(i, 2) & "|" & d(i, 3) & "|" & d(i, 4) .Item(c) = .Item(c) + 1 Next For i = UBound(d, 1) To 2 Step -1 c = d(i, 2) & "|" & d(i, 3) & "|" & d(i, 4) If .Item(c) < 4 Then a = a & ",a" & i If Len(a) > 245 Then r.Range(Mid(a, 2)).EntireRow.Delete a = vbNullString End If End If Next If Len(a) > 1 Then r.Range(Mid(a, 2)).EntireRow.Delete a = vbNullString End If End With Application.ScreenUpdating = 1 End Sub




Reply With Quote
Bookmarks