Loop column to check duplicates

[nicolastella]

I have this code where it looks if duplicate exist in a column ("D"), and then it give me a message if a duplicate is found or not. This is working great in Excel VBA. However, I'm controlling this workbook thru Autodesk Invertor VBA, and, for some reason I couldn't figure it out, it give me ALWAYS the detection of duplicates. Any thoughts? I'm using the Scripting. Dictionary function, does it need some reference? Thanks all

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

'Create worksheet3

Dim WS As Worksheet
Set WS = Sheets.Add


'Copy cell to worksheet 3
Sheets("Sheet1").Select
Range("D2:D150").Select
Selection.Copy
Sheets("Sheet3").Select
Range("D2:D150").Select
ActiveSheet.Paste



' Delete empty rows
Sheets("Sheet3").Select
Range("D1:D150").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete


Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set sh = ThisWorkbook.Sheets("Sheet3")
Set dic = CreateObject("Scripting.Dictionary")

a = sh.Range("D1", sh.Range("D" & 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
End '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 "Anomalies found. Multiple rows with the same description"
End If

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

[rlv01]

You say it works under Excel, but after looking at your code I have low confidence in it. But setting that aside, the first thing you should do is get rid of all the selects and see if it works better when called from autocad.

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
    
    'Create worksheet3

    Dim WS As Worksheet
    Set WS = Sheets.Add

    Dim WS1 As Worksheet
    Dim WS3 As Worksheet

    Set WS1 = ThisWorkbook.Sheets("Sheet1")
    Set WS3 = ThisWorkbook.Sheets("Sheet3")

    'Copy cell to worksheet 3
    WS1.Range("D2:D150").Copy WS3.Range("D2:D150")

    ' Delete empty rows
    WS3.Range("D2:D150").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set sh = ThisWorkbook.Sheets("Sheet3")
    Set dic = CreateObject("Scripting.Dictionary")

    a = sh.Range("D1", sh.Range("D" & 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
        End                                           '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 "Anomalies found. Multiple rows with the same description"
    End If

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

[nicolastella]

Thanks for your reply, I appreciated. I'll try to modify it as you suggest. Code is working perfectly, for my purpose, in Excel, however, I'm not very familiar with VBA. Do you suggest a different/easier way to manage this process?

 

[rlv01]

If you have it working to your satisfaction, then it is probably not worth trying to upset the equilibrium.