Find a duplicate value in the column using VBA code

[krishna008]

I have an excel file with "Person" tab. I would like to check if any duplicate values are there in the column I, if duplicate values are present in Column I, we need to list them in a a new work book name as "anomalies report" with column headers as "Duplicate Value" and "Duplicate Columns" and list out all the duplicates in the anomalies sheet of "Anomalies Report" save it on desktop. If no anomalies don't create the new workbook.

Can I get the VBA code for this please?

 

[DanteAmor]

with column headers as "Duplicate Value" and "Duplicate Columns"

I'm not sure what data you want in each column.
It would help if you gave an example of what you have and the expected result.

Try the following macro, in the first column are the duplicate values:

Sub finddups()
  Dim sh As Worksheet
  Dim wb2 As Workbook
  Dim dic As Object
  Dim a As Variant
  Dim i As Long, j As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh = ThisWorkbook.Sheets("Person")
  Set dic = CreateObject("Scripting.Dictionary")
  
  a = sh.Range("I1", sh.Range("I" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  
  For i = 1 To UBound(a)
    If dic.exists(a(i, 1)) Then
      j = j + 1
      b(j, 1) = a(i, 1)
    End If
    dic(a(i, 1)) = i
  Next
  
  If j = 0 Then
    MsgBox "No anomalies"
  Else
    Set wb2 = Workbooks.Add
    Range("A1:B1").Value = Array("Duplicate Value", "Duplicate Columns")
    Range("A2").Resize(j).Value = b
    wb2.SaveAs Environ("USERPROFILE") & "\Desktop" & "\Anomalies Report", xlOpenXMLWorkbook
    wb2.Close
    MsgBox "Anomaly report created"
  End If
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

I hope to hear from you soon.
Respectfully
Dante Amor
_______________

 

[krishna008]

Thanks for the reply. I'm getting 400 error when executing
Set wb2 = Workbooks.Add
Range("A1:B1").Value = Array("Duplicate Value", "Duplicate Columns").

 

[DanteAmor]

Thanks for the reply. I'm getting 400 error when executing
Set wb2 = Workbooks.Add
Range("A1:B1").Value = Array("Duplicate Value", "Duplicate Columns").

On which line?

Try again:

Sub finddups()
  Dim sh As Worksheet
  Dim wb2 As Workbook
  Dim dic As Object
  Dim a As Variant
  Dim i As Long, j As Long
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh = ThisWorkbook.Sheets("Person")
  Set dic = CreateObject("Scripting.Dictionary")
  
  a = sh.Range("I1", sh.Range("I" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  
  For i = 1 To UBound(a)
    If dic.exists(a(i, 1)) Then
      j = j + 1
      b(j, 1) = a(i, 1)
    End If
    dic(a(i, 1)) = i
  Next
  
  If j = 0 Then
    MsgBox "No anomalies"
  Else
    Set wb2 = Workbooks.Add
    Range("A1").Value = "Duplicate Value"
    Range("A2").Resize(j).Value = b
    wb2.SaveAs Environ("USERPROFILE") & "\Desktop" & "\Anomalies Report", xlOpenXMLWorkbook
    wb2.Close
    MsgBox "Anomaly report created"
  End If
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub