Removing Duplicate Row based on a single difference between them

[Clauddvon]

Hello,

I have an Excel spreadsheet that contains the following columns:

AGENCY FORM_NUMBER TYPE_DESCRIPTION DEFAULT_SIDE FORM_CREATE_DATE COUNT(*)
AGENCY 1 1 EMPLOYEE DELETED 3-NOV-16 1
AGENCY 1 1 EXCEPTION 3-NOV-16 0

I would like to remove any form IF the form returned twice where the first is any type_description and the second entry is 'exception'.

IF only one row exists and is only 'exception' I want to keep that record, but if two rows exist for the same agency, same form but 'exception' "and some other" type_description are listed, I want to omit the 'exception' from being displayed. In other words, in the above example, I'm would like ONLY the employee row to be displayed and remove the exception row. In the above example; however, if the exception were the only row, I would want to keep it.

Could someone help shed light on how I would complete this type of process? Advanced Filters, Removing Duplicates and nothing else works because althogh to me they are duplicate records (same form just different type_descriptions), Excel doesn't see them as duplicates.

Thanks,

 

[sijpie]

I have coded this below. It works on a sample file that I made from your headings.

Test it (NOT on your masterfile).

Read the comments in the code, particularly those with <<< or >>> because you may need to adjust something here.

The code assumes it is run with the sheet active.

As the code is, it will not delete anything, but highlight those rows that would be deleted.
To have it in Delete mode, set the flag bDelFlag to True.

Enjoy

Option Explicit

Const bDelFlag As Boolean = False '<<< Set to False for highlighting, to True for deleting

Const iAGNCY As Integer = 1 'column A
Const iFORM As Integer = 2  'column B
Const iTYPE As Integer = 3  'column C
Const iDEF As Integer = 4   'column D


Sub FindDuplicatExeptions()
    Dim vIn As Variant, vOut As Variant, vHL As Variant
    Dim lRIn As Long, lROut As Long, lUBi As Long
    Dim lC As Long, lUBC As Long, lRChk As Long
    
    'Use arrays for very fast processing, specifically if the dataset is large
    'Read the total range into array vIn. >>> assumes range starts in A1
    vIn = Range("A1").CurrentRegion.Value
    'get the array size (number of rows)
    lUBi = UBound(vIn, 1)
    lUBC = UBound(vIn, 2)   'number of columns
    
    'set up output array and copy header row
    ReDim vOut(1 To lUBi, 1 To lUBC)
    For lC = 1 To lUBC
        vOut(1, lC) = vIn(1, lC)
    Next lC
    
    'set up array for highlighting
    If Not bDelFlag Then ReDim vHL(1 To lUBi)
    
    'Now loop through the input array. Copy the rows which do not have EXCEPTION. _
     If the row has exeption then check to see if there is a duplicate.
     lROut = 2
     For lRIn = 2 To lUBi
        If vIn(lRIn, iTYPE) = "EXCEPTION" Then
            'check to see if there is a 'duplicate' line
            For lRChk = 2 To lUBi
                If lRChk <> lRIn Then
                    If vIn(lRChk, iAGNCY) = vIn(lRIn, iAGNCY) And _
                        vIn(lRChk, iFORM) = vIn(lRIn, iFORM) And _
                        vIn(lRChk, iTYPE) <> vIn(lRIn, iTYPE) _
                        Then    'duplicate found
                        
                        'if highlight is on
                        If Not bDelFlag Then
                            vHL(lRIn) = True
                        Else
                        ' delete Exception row by not copying, ie do nothing
                        
                        End If
                    End If
                End If
            Next lRChk
        Else
            'copy row to out
            For lC = 1 To lUBC
                vOut(lROut, lC) = vIn(lRIn, lC)
            Next lC
            'increase counter for output row
            lROut = lROut + 1
        End If
    Next lRIn
     
     'Now for the output
    If bDelFlag Then 'overwrite the range with the output array
        Range("A1").CurrentRegion.Value = vOut
    Else
        'highlight
        For lRIn = 1 To lUBi
            If vHL(lRIn) Then
                Range("A1").CurrentRegion.Rows(lRIn).Interior.Color = RGB(200, 200, 10)
            End If
        Next lRIn
    End If
End Sub