Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
A speedy way to identify and label items that only occur once as "unique" using VBA in Excel
Option Explicit
Public Sub FastMarkDuplicatesWithDictionary()
'For timing purposes only -- this does not affect our macro!
Dim dblStart As Double
dblStart = Timer
Dim wksIDs As Worksheet
Dim varIDs As Variant, varStatus As Variant, _
varID As Variant
Dim strID As String
Dim lngLastRow As Long, lngIdx As Long
Dim dicDistincts As Scripting.Dictionary, _
dicDuplicates As Scripting.Dictionary
Set dicDistincts = New Scripting.Dictionary
Set dicDuplicates = New Scripting.Dictionary
'Set references up-front and make sure dictionaries
'use case-insensitive keys
Set wksIDs = ThisWorkbook.Worksheets("faster-with-dictionary")
lngLastRow = LastOccupiedRowNum(wksIDs)
dicDistincts.CompareMode = vbTextCompare
dicDuplicates.CompareMode = vbTextCompare
'Store the IDs in a variant array
varIDs = wksIDs.Range("A2:A" & lngLastRow)
'Copy the IDs variant array, will eventually
'overwrite this with "Unique" or "Duplicate" only
varStatus = varIDs
'Loop through the IDs variant array, adding distinct
'IDs to the dictionary
For Each varID In varIDs
'Assign the ID to a string for easy reference
strID = Trim(CStr(varID))
'Only considering non-blank cells
If strID <> vbNullString Then
'If this key does not exist in the distinct
'dictionary, add it
If Not dicDistincts.Exists(strID) Then
dicDistincts.Add Key:=strID, Item:=strID
'If it is already in the distinct dictionary,
'we know it's a duplicate!
'
'Here we'll check to see if it's already in the
'duplicate dictionary. If it is not, we add it
ElseIf Not dicDuplicates.Exists(strID) Then
dicDuplicates.Add Key:=strID, Item:=strID
End If
End If
Next varID
'Now we have two dictionaries: one containing all the
'distinct values and one containing all the values
'that occurred more than once (i.e. the duplicates).
'
'At this point, we can loop through the original
'list of IDs and check each value against the
'duplicate dictionary -- if the
'value is contained in that dictionary, we know it
'is a duplicate!
lngIdx = 1
For Each varID In varIDs
If dicDuplicates.Exists(CStr(varID)) Then
varStatus(lngIdx, 1) = "Duplicate"
Else
varStatus(lngIdx, 1) = "Unique"
End If
lngIdx = lngIdx + 1
Next varID
'Write the status array back to the sheet
wksIDs.Range("B2:B" & lngLastRow) = varStatus
'Let the user know we're done!
MsgBox "Finished the faster dictionary routine! Took " & _
Round(Timer - dblStart, 2) & " seconds..."
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Sheet, the worksheet we'll search to find the last row
'OUTPUT : Long, the last occupied row
'SPECIAL CASE: if Sheet is empty, return 1
Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
Dim lng As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
With Sheet
lng = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End With
Else
lng = 1
End If
LastOccupiedRowNum = lng
End Function
@RebJuma

This comment has been minimized.

Copy link

RebJuma commented Jun 24, 2016

Hi, I have run this code and it gives me an error (Compile erro; User-defines type not defined) and Highlights 'dicDistincts As Scripting.Dictionary, dicDuplicates As Scripting.Dictionary'.
I have tried using Set dicDistincts = CreateObject("Scripting.Dictionary")
but it is still not working, am new to VBA so I dont really know what the Problem is, please help, thanks

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.