Thread: Macro to find rows with duplicates, compare cells between them and delete rows.

Hello world,

This is my first post, please let me know if my question is not clear.

I am trying to write a macro to find duplicated in column F, see if they have matching values for column O and then delete all rows except for the one that has the longest string in column B.

I think I need to do the following (starting with value in F1 and finishing at the end of the column):

1) Look for duplicates in all column F
2) For each duplicate: check if values in column O are also duplicates
3) If the values in column O are duplicates, then delete all rows except for the one that has the most data in column B.

I am not sure how I should start writing a solution for this.

I know I can use the =LEN() function to check the number of characters in a cell.

However, I am not sure how to pass on the cell references of the duplicates in F so that I can search for duplicates in O. Once I have those references I can pass them on to check for the length of the strings in column B as well.

Then, to delete the rows would I use the row reference and EntireRow.Delete?

I have attached a spreadsheet with an example of what I am trying to achieve.

I have been browsing the forums for a long time but have never asked a question before.

Thanks for your help.

Try this:-
I've amended the code I produced yesterday, as I don't think it was correct !!

Sub MG30Jun58
Dim Rng     As Range
Dim Dn      As Range
Dim Twn     As String
Dim oMax    As Integer
Dim Rw      As Range
Dim nRng    As Range
Dim temp    As Range
Dim K
Set Rng = Range(Range("F1"), Range("F" & rows.count).End(xlUp))
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Dn.value = Dn.Offset(, 9) Then
        If Not .Exists(Dn.value) Then
                .Add Dn.value, Dn.Offset(, -4)
            Else
                Set .Item(Dn.value) = Union(.Item(Dn.value), Dn.Offset(, -4))
            End If
        End If
        Next Dn

For Each K In .keys
    oMax = 0
    For Each Rw In .Item(K)
        oMax = Application.max(Len(Rw), oMax)
        If Len(Rw) = oMax Then Set temp = Rw
    Next Rw
 
    For Each Rw In .Item(K)
        If Not Rw.Address = temp.Address Then
            If .Item(K).count > 1 Then
                If nRng Is Nothing Then
                    Set nRng = Rw
                Else
                    Set nRng = Union(nRng, Rw)
                End If
            Else
                If nRng Is Nothing Then
                    Set nRng = Rw
                Else
                    Set nRng = Union(nRng, Rw)
                End If
            End If
        End If
    Next Rw
 Next K

End With
nRng.EntireRow.Delete
End Sub

Regards Mick

Hi, This is the result of Modified code below.
NB:- In your previous thread you said that if any sets of cells for deletion in column "B" had values of the same length and also had the longest lengths, then remove all except one of them, That what my codes does , but you results show more than one.
As in 1234567890 which My code returns 2 and your 3.

Row No  Col(A)  Col(B)      Col(C)           Col(D)  Col(E)  Col(F)  Col(G)  Col(H)  Col(I)  Col(J)  Col(K)  Col(L)  Col(M)  Col(N)  Col(O)       
1.                          Require result                                                                                                        
2.              12345       12345                            DLM                                                                     622e76m0000j 
3.              1234567890  12345                            FRA                                                                     621e76l0000c 
4.              123456      1234567890                       HOR                                                                     623e76n000gw 
5.              1234        123456                           JOHNS                                                                   622e76m000ma 
6.              987654321   1234                             MA                                                                      622e76d0000b 
7.              987654321   1234567890                       MA                                                                      622e76d0000h 
8.              987654321   1234567890                       MA                                                                      622e76d00010 
9.              1234567890  987654321                        MCV                                                                     622e76m0000j 
10.             12334455    987654321                        RG                                                                      622e76m00007 
11.                         987654321                                                                                                             
12.                         12334455

New Code:-

Sub MG30Jun57
Dim Rng     As Range
Dim Dn      As Range
Dim Twn     As String
Dim oMax    As Integer
Dim Rw      As Range
Dim nRng    As Range
Dim temp    As Range
Dim K
Set Rng = Range(Range("F1"), Range("F" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Application.CountIf(Rng.Offset(, 9), Dn.Offset(, 9)) > 1 Then
        If Not .Exists(Dn.Value) Then
                .Add Dn.Value, Dn.Offset(, -4)
            Else
                Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, -4))
            End If
        End If
        Next Dn

For Each K In .keys
    oMax = 0
    For Each Rw In .Item(K)
        oMax = Application.Max(Len(Rw), oMax)
        If Len(Rw) = oMax Then Set temp = Rw
    Next Rw
 
    For Each Rw In .Item(K)
        If Not Rw.Address = temp.Address Then
            If .Item(K).Count > 1 Then
                If nRng Is Nothing Then
                    Set nRng = Rw
                Else
                    Set nRng = Union(nRng, Rw)
                End If
            Else
                If nRng Is Nothing Then
                    Set nRng = Rw
                Else
                    Set nRng = Union(nRng, Rw)
                End If
            End If
        End If
    Next Rw
 Next K

End With
'nRng.Interior.ColorIndex = 6
'MsgBox nRng.Address
nRng.EntireRow.Delete
End Sub

Regards Mick