Array Question - look for duplicates

[johnske]

Hi,

There's probably a far better way of doing this, but I've been playing around with the code below, and seeing I've got this far, how do you search though an array of values to see whether there are any duplicated values in the array?

John

EDIT: Let me clarify that a bit...we can assume that there are no existing duplicates in the array, but we want to check that any NEW entry(s) is not duplicating a previous entry.


Option Explicit
Private Sub Worksheet_Deactivate()
Dim Lost, i%, N%, BinaryNum!, BinarySum!
Dim MyArray(36) As Single
For N = 6 To 41 'rows 6 to 41
Worksheets("DB_36").Select
With Worksheets("DB_36").Rows(N)
Set Lost = .Find(What:="*", LookIn:=xlValues, searchorder:=xlByRows)
If Not Lost Is Nothing Then
BinarySum = 0
For i = 1 To 5
Set Lost = .FindNext(Lost)
BinaryNum = 2 ^ (Lost.Column)
'//BinarySum is a unique number if there are no duplicates
BinarySum = BinarySum + BinaryNum
Next i
MyArray(N - 5) = BinarySum
End If
End With
Next N
' If one of the array values is the same as another Then
MsgBox "You have duplicated entries ! - Change one of them"
' select the row with the last duplicated entry
' Else
' End If
End Sub

[Jacob Hilderbrand]

You will have to check each element in the array for each value. Something like this:


Dim Duplicate As Boolean
Dim i As Long
Dim MyValue As String
MyValue = 'This is the value currently being checked
For i = 1 to UBound(MyArray)
If MyArray(i) = MyValue Then
Duplicate = True
Exit For
End If
Next i
If Duplicate = True Then
Msgbox MyArray & " is duplicated"
End If

[Richie(UK)]

Hi John,

Youmay find this JW link useful:
http://j-walk.com/ss/excel/tips/tip15.htm

HTH

[johnske]

Thanx very much Jacob, Ritchie,

Was having problems getting the correct answer, but Jwalks 'UniqueItem' function sorted it out easily.

I.E. If the number of unique items is not equal to the total number of items then there is obviously a duplicate.... :thumb

John

[Jacob Hilderbrand]

If you only want to find if there is at least one duplicate (well I suppose that should be two duplicates...) then use an Exit statement in your loop to kick the code out once a duplicate is found. Since the loop may be very slow depending on the array size.

[mdmackillop]

How about using Match, as suggested in answer here.
MD
http://www.vbaexpress.com/forum/showthread.php?t=1148


Sub TestArray()
Dim X, YourStr, NumThere As Boolean, NumPos As Long
X = Array("AA", "BB", "CC", "DD")
YourStr = "CC"
On Error Resume Next
NumPos = Application.WorksheetFunction.Match(YourStr, X, 0)
If NumPos > 0 Then NumThere = True
On Error GoTo 0
If NumThere Then
MsgBox "The string " & YourStr & " is in position " & NumPos
Else
MsgBox "The string " & YourStr & " is not in the array"
End If
End Sub

[mdmackillop]

The following works with numbers, where the range is a single column/row

Sub TestArray()
Dim Item, YourStr, NumThere As Boolean, NumPos As Long
Dim X, i
X = Range("TestArea")
YourStr = InputBox("Enter number") * 1
MsgBox Belongs(YourStr, X)
End Sub

Function Belongs(Item, MyArray As Variant) As Boolean
Dim NumPos As Long
Belongs = False
On Error Resume Next
NumPos = Application.WorksheetFunction.Match(Item, MyArray, 0)
If NumPos > 0 Then Belongs = True
End Function

[johnske]

Thanx for the input Malcolm,

But I have this (below) working now, and it's quick, so will leave it at that for now

John

EDIT: PS It also gives the correct results, and, as it is to be used fairly extensively throughout the project, by declaring it as a public function it saves me a lot of typing/copying :)


Option Explicit

Private Sub CheckIsNew30RoundButton_Click()
Dim Lost, i%, N%, BinaryNum#, BinarySum#
Dim MyArray(1 To 50) As Double, MyValue#
Application.ScreenUpdating = False
For N = 6 To 56 'rows 6 to 56
With Worksheets("DB_30").Rows(N)
Set Lost = .Find(What:="*", LookIn:=xlValues, searchorder:=xlByRows)
If Not Lost Is Nothing Then
BinarySum = 0
For i = 1 To 6
Set Lost = .FindNext(Lost)
BinaryNum = 2 ^ (Lost.Column)
BinarySum = BinarySum + BinaryNum
Next i
MyArray(N - 5) = BinarySum
End If
End With
Next N
Application.ScreenUpdating = True
Range("b65536").End(xlUp).Offset(1, 0).Select
If ActiveCell.Row - 5 <> UniqueItems(MyArray, True) Then
MsgBox "Sorry, your entry for a " & ActiveCell.Offset(-1, 0) & _
" round" & vbLf & _
"duplicates a pre-existing round and will be deleted", , "ERROR ! - You must change your entry."
ActiveCell.EntireRow.Offset(-1, 0).Delete
Else
MsgBox "Congratulations, your " & ActiveCell.Offset(-1, 0) _
& " round is indeed a new round", , "The New Round Has Been Listed..."
End If
End Sub

Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input (This function By JWalk)
' If Count = True or is missing, the function returns the number
' of unique elements
' If Count = False, the function returns a variant array of unique
' elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer, NumUnique As Integer
Dim FoundMatch As Boolean
' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' Counter for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
GoTo AddItem '(Exit For-Next loop)
End If
Next i
AddItem:
' If not in list, add the item to unique list
If Not FoundMatch Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function