Error while finding duplicate with Application.WorksheetFunction.Match

[roypogo]

Hi All,

I am trying to find the duplicates in a source sheet "Data" and print the duplicate values in another sheet "Data Errors".

I am using the below code :

Sub Macro3()
'
' Macro3 Macro
'


'
Dim i, j As Long


Dim LastRow, LastCol As Long
Dim DataCell, DataRange As Range
Sheets("Data").Activate
With Worksheets("Data")
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set DataRange = Range(Cells(1, 1), Cells(LastRow, LastCol))



For i = 1 To LastCol
If DataRange.Cells(1, i).Value = "NM1*IL*1 - Member Name" Then
For j = 2 To LastRow
If Cells(j, i) <> "" Then
matchFoundIndex = Application.WorksheetFunction.Match(Cells(j, i), Range(Cells(1, i), Cells(LastRow, i)), 0)
If j <> matchFoundIndex Then
tmp = Sheet1.Cells(j, i).Value
With Worksheets("Data Errors")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = "Duplicate in Row " & j
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = tmp
End With
End If
End If
Next j
End If
Next i
End With
End Sub


When my data is as below it is giving me correct output:

Source:
[TABLE="width: 168"]
<tbody>[TR]
[TD]NM1*IL*1 - Member Name[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD]a[/TD]
[/TR]
[TR]
[TD]b[/TD]
[/TR]
[TR]
[TD]c[/TD]
[/TR]
[TR]
[TD]a[/TD]
[/TR]
[TR]
[TD]c[/TD]
[/TR]
[TR]
[TD]d[/TD]
[/TR]
[TR]
[TD="align: right"]10[/TD]
[/TR]
[TR]
[TD="align: right"]11[/TD]
[/TR]
[TR]
[TD="align: right"]10[/TD]
[/TR]
[TR]
[TD="align: right"]13

Output:
[TABLE="width: 187"]
<tbody>[TR]
[TD]Duplicate in Row 4[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD]Duplicate in Row 8[/TD]
[TD]a[/TD]
[/TR]
[TR]
[TD]Duplicate in Row 9[/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD]Duplicate in Row 13[/TD]
[TD="align: right"]10[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]


But if my data is as below:

[TABLE="width: 439"]
<tbody>[TR]
[TD]NM1*IL*1 - Member Name[/TD]
[/TR]
[TR]
[TD]NM1*IL*1*AARON*ADAM*C***34*11111~[/TD]
[/TR]
[TR]
[TD]NM1*IL*1*ABATE*CHARLES*A***34*11111~[/TD]
[/TR]
[TR]
[TD]NM1*IL*1*ABBETT*CARRIE*M***34*11111~[/TD]
[/TR]
[TR]
[TD]NM1*IL*1*ABBEY*HERSCHEL*D***34*11111~[/TD]
[/TR]
[TR]
[TD]NM1*IL*1*ABBOTT*MELISSA*B***34*11111~[/TD]
[/TR]
[TR]
[TD]NM1*IL*1*ABBOTT*LEWIS*M***34*11111~[/TD]
[/TR]
[TR]
[TD]NM1*IL*1*ABDAL-SABUR*JAWWAAD****34*11111~[/TD]
[/TR]
[TR]
[TD]NM1*IL*1*ABED*AARON*D***34*28~[/TD]
[/TR]
[TR]
[TD]NM1*IL*1*ABED*AARON*D***34*28~


It is giving me error as :

Run time error '1004'
Unable to get the Match property of the WorksheetFunction Class


Need help !!![/TD]
[/TR]
</tbody>[/TABLE]

 

[JackDanIce]

With the data you posted, this works without removing "~" and found 1 duplicate in row 10:

Sub ListDuplicates()

    Dim arr()   As Variant
    Dim temp    As Variant
    Dim dic     As Object
    Dim x       As Long
       
    Const DUPE As String = "Duplicate in Row: "
    Set dic = CreateObject("Scripting.dictionary")
    x = 1
    
    With Sheets("Data")
        y = .Cells(1, .Columns.Count).End(xlToLeft).column
        On Error Resume Next
        x = .Cells(1, 1).Resize(, y).find("NM1*IL*1 - Member Name", LookIn:=xlValues, MatchCase:=True).column
        On Error GoTo 0
        
        If x = 1 Then Exit Sub
        arr = .Cells(1, x).Resize(.Cells(.Rows.Count, x).End(xlUp).row, 2).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        If LenB(arr(x, 1)) > 0 Then
            'temp = Replace(arr(x, 1), "~", "")
            temp = arr(x, 1)
            arr(x, 1) = vbNullString
            dic(temp) = IIf(dic.exists(temp), dic(temp), 0) + 1
            If dic(temp) > 1 Then
                arr(x, 1) = DUPE & x
                arr(x, 2) = temp
            End If
        End If
    Next x

    Application.ScreenUpdating = False
    With Sheets("Data Errors").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2))
        .Value = arr
        .Resize(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
    
    Erase arr
    Set dic = Nothing
    
End Sub

Though you have a working solution now anyway!

 

[JackDanIce]

Double posted (n/a)

 

[Marcelo Branco]

It worked !!!!

Thanks

Great! Glad to help

M.