Loop column to check duplicates

nicolastella

New Member
Joined
May 13, 2019
Messages
6
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
 

Attachments

  • BOM.jpg
    BOM.jpg
    144.8 KB · Views: 10

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
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.
VBA Code:
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
 
Upvote 0
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?
 
Upvote 0
If you have it working to your satisfaction, then it is probably not worth trying to upset the equilibrium.
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,107
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top