Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Find and Delete Duplicate entries | Excel Discussion (Misc queries) | |||
How do I find duplicate entries in Excel | Excel Discussion (Misc queries) | |||
Find duplicate entries | Excel Discussion (Misc queries) | |||
find and delete duplicate entries in two columns or find and prin. | Excel Programming | |||
Find Duplicate Entries | Excel Programming |