Help Excel formula eliminate duplicate values and keep only 2 identical rows.

[Nguyen Anh Dung]

as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9 rows,etc.... How to delete duplicate values and keep only 2 rows

link file:

1.csv

drive.google.com

 

[Nguyen Anh Dung]

Sub v()
With Range("D2:D" & Cells(Rows.Count, "A").End(3).Row)
    .Formula = "=IF((A2<>A1)+(COUNTIF(A$2:A2,A2)=4)+(COUNTIF(A$2:A2,A2)=8)+(COUNTIF(A$2:A2,A2)=12)+(A2<>A3),""k"",1)"
    .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
    .ClearContents
End With
End Sub

nice!!! thanks you so much!!!

 

[Nguyen Anh Dung]

nice!!! thanks you so much!!!

Hi footoo,
if In this case column < 16 rows. only 1 or 2 or 3 or 4 or 5. i want keep it?
thanks you and best regards,

 

[footoo]

Hi footoo,
if In this case column < 16 rows. only 1 or 2 or 3 or 4 or 5. i want keep it?
thanks you and best regards,

You need to explain in more detail.
Also, when replying, include any other requirements so as to avoid having to do it in bits and pieces.

 

[Nguyen Anh Dung]

You need to explain in more detail.
Also, when replying, include any other requirements so as to avoid having to do it in bits and pieces.

Thanks you reply!!!
the below picture
if rows duplicate <5 then kepp all, if duplicate = 6 then keep 5, 7 keep 5, 8 keep 5, 9 keep 5, 10 keep 5 , 11 keep 5, 12 keep 5 (keep random)
best regards!!!

 

[footoo]

Sub v()
Dim rng As Range, a As Range, cel As Range, i%
With Range("D2:D" & Cells(Rows.Count, "A").End(3).Row)
    .Formula = "=IF((A2<>A1)+(A2<>A3),1,"""")"
    .Value = .Value
    Set rng = .SpecialCells(xlCellTypeBlanks)
    For Each a In rng.Areas
        If a.Count < 4 Then
            a = 1
        ElseIf a.Count < 11 Then
            a(a.Count + 1, 1).ClearContents
            [E2].Resize(a.Count + 1) = Evaluate("ROW(1:" & a.Count + 1 & ")")
            With [F2].Resize(a.Count + 1)
                .Formula = "=RAND()"
                .Value = .Value
            End With
            [E2].Resize(a.Count + 1, 2).Sort Key1:=[F2], Order1:=xlAscending, Header:=xlNo
            For i = 1 To 4
                a.Item([E2].Item(i, 1)) = 1
            Next
            [E:F].ClearContents
        Else
            Union(a(3), a(7), a(11)) = 1
        End If
    Next
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .ClearContents
End With
End Sub

 

[Nguyen Anh Dung]

Sub v()
Dim rng As Range, a As Range, cel As Range, i%
With Range("D2:D" & Cells(Rows.Count, "A").End(3).Row)
    .Formula = "=IF((A2<>A1)+(A2<>A3),1,"""")"
    .Value = .Value
    Set rng = .SpecialCells(xlCellTypeBlanks)
    For Each a In rng.Areas
        If a.Count < 4 Then
            a = 1
        ElseIf a.Count < 11 Then
            a(a.Count + 1, 1).ClearContents
            [E2].Resize(a.Count + 1) = Evaluate("ROW(1:" & a.Count + 1 & ")")
            With [F2].Resize(a.Count + 1)
                .Formula = "=RAND()"
                .Value = .Value
            End With
            [E2].Resize(a.Count + 1, 2).Sort Key1:=[F2], Order1:=xlAscending, Header:=xlNo
            For i = 1 To 4
                a.Item([E2].Item(i, 1)) = 1
            Next
            [E:F].ClearContents
        Else
            Union(a(3), a(7), a(11)) = 1
        End If
    Next
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .ClearContents
End With
End Sub

Thanks you so much!!!