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
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