Programatically find Duplicate entries
 

Hello. I have some code that when a button is pushed, takes a list of data
(columnA) and manipulates it. Is there a way to, upon pushing the button,
first perform a scan of columnA, and determine if there are duplicates in
that column? And ideally, identify in a message box which cells have
duplicate entries?

-Steph

Programatically find Duplicate entries
 

This list both ends of the duplication

Sub Dups()
Dim iLastRow As Long
Dim i As Long
Dim sCells As String
Dim rng As Range

iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range("A1:A" & iLastRow)
For i = 1 To iLastRow
If Application.CountIf(rng, Cells(i, "A")) 1 Then
sCells = sCells & Cells(i, "A").Address(False, False) & ","
End If
Next i
sCells = Left(sCells, Len(sCells) - 1)
MsgBox "Duplicates found in " & vbCrLf & sCells

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Steph" wrote in message
...
Hello. I have some code that when a button is pushed, takes a list of
data
(columnA) and manipulates it. Is there a way to, upon pushing the button,
first perform a scan of columnA, and determine if there are duplicates in
that column? And ideally, identify in a message box which cells have
duplicate entries?

-Steph

Programatically find Duplicate entries
 

Bob's code is great and will do just what you want. Here is some code that I
have in an addin acttached to a menu button for generating list of unique
itmes and list of duplicate items. It is probably overkill for what you want
but here it is... You need to reference it to Microsoft Scripting Runtime...

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub


"Steph" wrote:

Hello. I have some code that when a button is pushed, takes a list of data
(columnA) and manipulates it. Is there a way to, upon pushing the button,
first perform a scan of columnA, and determine if there are duplicates in
that column? And ideally, identify in a message box which cells have
duplicate entries?

-Steph

Programatically find Duplicate entries
 

Thanks guys!!

"Jim Thomlinson" wrote in message
...
Bob's code is great and will do just what you want. Here is some code that
I
have in an addin acttached to a menu button for generating list of unique
itmes and list of duplicate items. It is probably overkill for what you
want
but here it is... You need to reference it to Microsoft Scripting
Runtime...

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to
check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary
object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste
range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to
check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary
object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To
UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items
to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste
range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub


"Steph" wrote:

Hello. I have some code that when a button is pushed, takes a list of
data
(columnA) and manipulates it. Is there a way to, upon pushing the
button,
first perform a scan of columnA, and determine if there are duplicates
in
that column? And ideally, identify in a message box which cells have
duplicate entries?

-Steph