Detecting Duplicate entries

[Stefan15]

Dear Forum,

I have a file with over 100,000 rows of excel data, what am trying to achieve is to detect duplicate entries from this file. The only way to detect true duplicate is to match duplicates in 2 separate columns. That is, if there is a duplicate vendor name and duplicate Reference number, then there is a duplicate.

If there is a match, the status column should state “duplicate” otherwise “Single”

See example below, I am open to ideas on how to go about this and possibly a VBA code that would help.

SN	Date	Year	Group	Vendor name	Doc Date	Amount	Reference No	Posting Date	Posted by	Status
				John’s Ltd			00582671			Duplicate
				John’s Ltd			00582671			Duplicate
				Best Western Hotel			00225874			Duplicate
				Best Western Hotel			00225874			Duplicate

Thanks

[offthelip]

try this , i have assumed the two columns are in A and B and then I output the results to Column C, if you want to use columns which are spaced apart just load two inarr arrays and concatenate them.

Sub dupcheck()lastrow = Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(Cells(1, 1), Cells(lastrow, 2))
Range(Cells(1, 3), Cells(lastrow, 3)) = "Single"
outarr = Range(Cells(1, 3), Cells(lastrow, 3))
Dim conar() As Variant
txt = "Duplicate"
ReDim conar(1 To lastrow)


For i = 1 To lastrow
' concatenate the two columns
 conar(i) = inarr(i, 1) & inarr(i, 2)
Next i
 ' now search for duplicates
  For i = 1 To lastrow - 1
     If outarr(i, 1) <> txt Then
           For j = i + 1 To lastrow
              If conar(i) = conar(j) Then
              ' dup found
              outarr(i, 1) = txt
              outarr(j, 1) = txt
              End If
           Next j
      End If
   Next i
              
Range(Cells(1, 3), Cells(lastrow, 3)) = outarr


End Sub

[mdmackillop]

Another to try

Sub Test()


Dim arr, reslt
Dim Combo As String
Dim dic As Object
Dim Col1, Col2, Col3

Col1 = 5  'First data
Col2 = 8   'Second Data
Col3 = 10   'Result

Set dic = CreateObject("Scripting.dictionary")
arr = Cells(1, 1).CurrentRegion
x = UBound(arr)
reslt = Cells(1, Col3).Resize(x)
For i = 2 To x
Combo = arr(i, Col1) & "_" & arr(i, Col2)
If Not dic.Exists(Combo) Then
    dic.Add Combo, i
    reslt(i, 1) = "Single"
Else
    reslt(dic(Combo), 1) = "Duplicate"
    reslt(i, 1) = "Duplicate"
End If
Next
Cells(1, Col3).Resize(x) = reslt
End Sub

[mdmackillop]

A more flexible approach

Option Explicit
Sub Test()
    Dim Arr, Reslt
    Dim Combo As String
    Dim Dic As Object
    Dim Cols, c
    Dim i&, j&, x&
    Dim R As Range
    Dim RCol&


    'Columns to compare
    Cols = Array(3, 5, 7)
    'Results column
    RCol = 10
    
    Set Dic = CreateObject("Scripting.dictionary")
    Arr = Cells(1, 1).CurrentRegion
    x = UBound(Arr)
    Set R = Cells(1, RCol).Resize(x)
    Reslt = R
    For i = 2 To x
        Combo = ""
        For Each c In Cols
            Combo = Combo & Arr(i, c) & "||"
        Next c
        If Not Dic.Exists(Combo) Then
            Dic.Add Combo, i
            Reslt(i, 1) = "Single"
        Else
            Reslt(Dic(Combo), 1) = "Duplicate"
            Reslt(i, 1) = "Duplicate"
        End If
    Next
    R.Value = Reslt
End Sub

[Stefan15]

Thanks for the your feedback's.

The first 2 codes are bringing up 'Compile Error" while the 3rd code is considers only duplicate in Vendor name without matching with duplicate reference no. also the duplicate/single status has replaces the data on the amount column.

What i am trying to achieve is that, duplicate vendor name should match with duplicate reference number and where there is a match the last column which is the status column should state either duplicate or single

Thanks once again for your help

[mdmackillop]

Post a sample workbook if you want code tested.

[Paul_Hossler]

Something simple using a collection

You might have to adjust some cell references

Capture.JPG

Option Explicit

Sub MarkDups()
    Dim r As Long, N As Long
    Dim K As String
    
    Dim C As Collection
    
    Set C = New Collection
    
    With ActiveSheet
        For r = 2 To .Cells(1, 1).CurrentRegion.Rows.Count
            K = .Cells(r, 5).Value & "#" & .Cells(r, 8).Value
            
            On Error Resume Next
            C.Add 0, K
            On Error GoTo 0
            
            N = C(K) + 1
            
            C.Remove (K)
            C.Add N, K
        Next r
    
        For r = 2 To .Cells(1, 1).CurrentRegion.Rows.Count
            K = .Cells(r, 5).Value & "#" & .Cells(r, 8).Value
            .Cells(r, 11).Value = IIf(C(K) = 1, "Single", "Duplicate")
        Next r
    End With
End Sub

[Stefan15]

Something simple using a collection

You might have to adjust some cell references

Capture.JPG

Option Explicit

Sub MarkDups()
    Dim r As Long, N As Long
    Dim K As String
    
    Dim C As Collection
    
    Set C = New Collection
    
    With ActiveSheet
        For r = 2 To .Cells(1, 1).CurrentRegion.Rows.Count
            K = .Cells(r, 5).Value & "#" & .Cells(r, 8).Value
            
            On Error Resume Next
            C.Add 0, K
            On Error GoTo 0
            
            N = C(K) + 1
            
            C.Remove (K)
            C.Add N, K
        Next r
    
        For r = 2 To .Cells(1, 1).CurrentRegion.Rows.Count
            K = .Cells(r, 5).Value & "#" & .Cells(r, 8).Value
            .Cells(r, 11).Value = IIf(C(K) = 1, "Single", "Duplicate")
        Next r
    End With
End Sub

Many thanks Paul, the code works like Magic.

And thank you to everyone that gave this a shot, I really appreciate the efforts.

Paul, please am learning vba, if it is not too much to ask, i was hoping if you can provide me with step by step explanation of what each line of code does?

Thanks once again

[Stefan15]

Dear Forum Members

Please am new to VBA and i will appreciate if someone could help explain each line of this code for better understanding thanks

Option Explicit

Sub MarkDups()
Dim r As Long, N As Long
Dim K As String

Dim C As Collection

Set C = New Collection

With ActiveSheet
For r = 2 To .Cells(1, 1).CurrentRegion.Rows.Count
K = .Cells(r, 5).Value & "#" & .Cells(r, 8).Value

On Error Resume Next
C.Add 0, K
On Error GoTo 0

N = C(K) + 1

C.Remove (K)
C.Add N, K
Next r

For r = 2 To .Cells(1, 1).CurrentRegion.Rows.Count
K = .Cells(r, 5).Value & "#" & .Cells(r, 8).Value
.Cells(r, 11).Value = IIf(C(K) = 1, "Single", "Duplicate")
Next r
End With
End Sub

[Paul_Hossler]

Option Explicit 
 
Sub MarkDups() 
    Dim r As Long, N As Long 
    Dim K As String 

'Dim's a Collection object - check online help     
    Dim C As Collection 

'Instantiates (sort of like 'creates')     
    Set C = New Collection 

'use With ... End With for an object saves typing, but also make the logic more visible
    With ActiveSheet 

'goes from row 2 to the number of rows in the block surrounding A1 = .Cells(1,1)
        For r = 2 To .Cells(1, 1).CurrentRegion.Rows.Count 

'formats a 'Key' equals to Cell in col 5 + a # + the cell in col 8 since it's the combination of 5+8 that defines a duplicate
            K = .Cells(r, 5).Value & "#" & .Cells(r, 8).Value 


'if there's an error ignore it - would occur if a Collection entry with the key K already exists
            On Error Resume Next 

'if K exists in collection, it can't be added
'if K does NOT exist, then add it with a data value = 0
            C.Add 0, K 
'turn off the Ignore Errors
            On Error GoTo 0 

'get the data value from the collection item K, put it in N and add 1             
            N = C(K) + 1 

'we know that there's a K since we either added it above or we retrieved it and added 1
'remove the old K and add a new one with data value = old value + 1
            C.Remove (K) 
            C.Add N, K 
        Next r 

'again, go from row 2 to the end of data         
        For r = 2 To .Cells(1, 1).CurrentRegion.Rows.Count 
'construct a temp string (just for ease)  = col 5 plus # plus col8
            K = .Cells(r, 5).Value & "#" & .Cells(r, 8).Value 

'if the data value for K = 1, put Single in col 11, otherwise put Duplicate in col11
            .Cells(r, 11).Value = IIf(C(K) = 1, "Single", "Duplicate") 
'get the next row
        Next r 
    End With 
End Sub

[Stefan15]

Many Thanks Paul.