This sub clears exact duplicate rows between two columns.

Right now, if its finds a new pair in columns F & G, it will clear that pair throughout F & G.

I'm trying to think of a way to either have it reset after a duplicates been cleared, so that it doesn't accidently clear values that happen to be duplicates, but aren't true duplicates. The only true ones, will be directly below the original values.

Sub clearDups1()

    Dim lngMyRow As Long
    Dim lngMyCol As Long
    Dim lngLastRow As Long
    Dim objMyUniqueData As Object
   
    Application.ScreenUpdating = False

    lngLastRow = Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
   
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")
   
    For lngMyRow = 1 To lngLastRow 'Assumes the data starts at row 1. Change to suit if necessary.
        If objMyUniqueData.Exists(CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7))) = False Then
            objMyUniqueData.Add CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7)), Cells(lngMyRow, 6) & Cells(lngMyRow, 7)
        Else
            Range(Cells(lngMyRow, 6), Cells(lngMyRow, 7)).ClearContents
        End If
    Next lngMyRow
   
    Set objMyUniqueData = Nothing
   
    Application.ScreenUpdating = True
   
End Sub

Any input appreciated.

CodePudding user response：

You don't need a dictionary for this:

Sub clearDups1()

    Dim lngMyRow As Long, lngLastRow As Long, ws As Worksheet
    Dim k As String, kPrev As String
    
    Set ws = ActiveSheet
    lngLastRow = ws.Range("F:G").Find("*", SearchOrder:=xlByRows, _
                                      SearchDirection:=xlPrevious).row
   
    Application.ScreenUpdating = False
    kPrev = Chr(0) 'won't occur in your data
    For lngMyRow = 1 To lngLastRow 'Assumes the data starts at row 1. Change to suit if necessary.
        k = CStr(ws.Cells(lngMyRow, 6).Value) & "<>" & CStr(ws.Cells(lngMyRow, 7).Value)
        If kCurr = k Then 'same as previous row?
            ws.Cells(lngMyRow, 6).Resize(1, 2).ClearContents
        End If
        kPrev = k 'set as key for previous row
    Next lngMyRow
    Application.ScreenUpdating = True
End Sub

CodePudding user response：

You can also try this code. It does what you have asked.

1. Leave the first occurring of the same dups
2. Start from the bottom to delete them and leave the final which in our case will be original

Using the above ways you can achieve what you have asked for.

Sub clearDups() 
    Dim lR As Long, r As Long 
    Dim x As 99999 
    Dim f(x), g(x) As String 
    Dim lRow As Long, lCol As Long, i As Long 
    lRow = Range("F" & Rows.Count).End(xlUp).Row 
    For lR = 2 To lRow 
        f(lR - 1) = Cells(lR, "F").Value 
        g(lR - 1) = Cells(lR, "G").Value 
    Next 
    For Each s In f 
        i = i   1 
        If Application.CountIf(Range("F1:G" & lRow), s) = 2 Then 
            Cells(i, "F").Value = "" 
            Cells(i, "G").Value = "" 
        End If 
    Next 
End Sub