Hi!

I'm trying to write a code where I want to check for duplicate values in two non-contiguous columns on the same worksheet in Excel. The size of the columns however always changes depending on how many accounts there are for the year. For instance, some years there may only be 10 accounts while in other years there may be 15 accounts.

I tried to code to allow for the range of cells to be selected to change but everytime I run my code the error: 'Run-time error 1004: Application-defined or Object-defined error' will pop up.

This is my code:

Sub RepeatedAccs()
'
' this macro identifies the duplicated accs across both years
'
    ' duplicates Analysis sheet and renames it to Repeated Accs
    Worksheets("Analysis").Copy After:=Sheets("Analysis")
    Sheets("Analysis (2)").Name = "Repeated Accs (2)"
   
    Dim Cell As Range
    Dim lastrow As Long
    Dim twentyP As Variant
    Dim eightP As Variant ' if declared As Integer, overflow error will occur i.e. result is too large to be represented
    Dim a As Variant
   
    lastrow = Cells(rows.Count, "C").End(xlUp).Row
    a = Sheets("Analysis").Range("C5:C" & lastrow)
    twentyP = WorksheetFunction.Percentile_Exc(a, 0.2)
    eightP = WorksheetFunction.Percentile_Exc(a, 0.8)
    Range("C5:C" & lastrow).Select
   
    With Sheets("Repeated Accs (2)")
       
        ' For Each Cell In .Range("C5:C" & .Cells(.rows.Count, "C").End(xlUp).Row)
        For Each Cell In Selection
            If Cell.Value >= twentyP And Cell.Value <= eightP Then
                ' a = Sheets("Repeated Accs (2)").Cells(Rows.Count, "C").End(xlUp).Row
                .rows(Cell.Row).ClearContents
                ' cannot delete cell because cell position will change
            End If
        Next
        Selection.SpecialCells(xlCellTypeBlanks).Select
        Selection.EntireRow.Delete
       
    End With
   
    With Sheets("Repeated Accs (2)")
        .Cells.FormatConditions.Delete 'deletes all conditional formatting rules i.e. top & bottom 20th percentile
    End With
   
    ' On Error Resume Next
    ' ActiveWorkbook.Worksheets("Repeated Accs (2)").Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    ' On Error GoTo 0
    '' Not enough memory for above code??
   
    ' ' Sort Abs Diff tables fm smallest to largest value
    Dim frow As Long
    frow = Cells(rows.Count, "A").End(xlUp).Row
    Range("A5:C" & frow).Sort key1:=Range("A5:A" & frow), order1:=xlAscending, Header:=xlNo

    ' ' Sort % Diff tables fm smallest to largest value
    Dim lrow As Long
    lrow = Cells(rows.Count, "E").End(xlUp).Row
    Range("E5:G" & lrow).Sort key1:=Range("E5:E" & lrow), order1:=xlAscending, Header:=xlNo
           
    ' ' Check for duplicate values
    Dim b As Variant, c As Variant
    Dim y As Variant
    Set b = Sheets("Repeated Accs (2)").Range("A5:A" & frow)
    Set c = Sheets("Repeated Accs (2)").Range("E5:E" & lrow)
    Set y = Application.Union(b, c)
    With Sheets("Repeated Accs (2)")
        .Range(y).Parent.Select
    End With
    Range("E5").Activate
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TineAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
   
End Sub

The underlined portion is where the error occurs.

Can anyone tell me what's wrong and how I can fix it?

Thanks a million!