Solved

# create an unique array

Posted on 2002-04-17
175 Views
Hi,

arr1() is an array consists of 9 different items as follows:

arr1(1) = “Red” , arr1(2) = “Blue”, arr1(3) = “Blue”, arr1(4) = “Yellow”, arr1(5) = “Red”, arr1(6) = “Red”, arr1(7) = “Blue”, arr1(8) = “Green”, arr1(9) = “Red”

I need the code which can create arr2() which should be an UNIQUE array, I mean it should be as follows:  arr2(1) = “Red” , arr2(2) = “Blue”, arr2(3) = “Yellow”, arr2(4) = “Green”

Notes: arr1() items are not fixed (every time contains different Data)  THEN  the long of arr2() is not fixed (it depends on arr1() data)

ray14
0
Question by:ray14
• 5
• 3
• 2
• +2

LVL 100

Expert Comment

ID: 6948544
Sounds like homework.

Try something along these lines

dimension arr2()  ' allows it to be redimensioned

for each element of arr1
set found = false
loop through the elements of arr2
if arr1(x) = arr2(y)
set found = true
redeimension arr2 to current size +1
set max element of arr2 to arr1(x)

arr2 now has the unique values in arr1

mlmcc
0

LVL 15

Expert Comment

ID: 6948570
Option Explicit

Text1.Text = "Red Blue Blue Yellow Red Red Blue Green Red"
End Sub

Private Sub Text1_Change()
Dim arr1() As String, arr2() As String, i As Long

arr1 = Split(Text1.Text, " ")
arr2 = RemoveDupes(Split(Text1.Text, " "))
Caption = ""
For i = 0 To UBound(arr2) - 1
Caption = Caption & arr2(i) & " "
Next
End Sub

Public Function RemoveDupes(arr As Variant) As Variant
Dim col As Collection, v As Variant, i As Long, arrResult() As String
On Error Resume Next
Set col = New Collection

' uses the fact that collection doesn't accept items with the same key
For i = 0 To UBound(arr) - 1
If Err Then ' item already exists
Err.Clear
End If
Next

' copy from collection to array
ReDim arrResult(0 To col.Count - 1)
For i = 1 To col.Count
arrResult(i - 1) = col.Item(i)
Next

RemoveDupes = arrResult ' return array
End Function
0

LVL 3

Accepted Solution

Bahnass earned 50 total points
ID: 6948581
First thing choose a char that is sure not included inside any array element
(may be Tab)

For I = 1 To UBound(arr1)
If InStr(sArr, arr1(I)) = 0 Then
sArr = sArr & arr1(I) & vbTab
End If
Next
arr2 = Split(sArr, vbTab)

for I = 1 to UBound (arr1)

sArr =sArr & arr1(I)
next
0

LVL 3

Expert Comment

ID: 6948583
too slow
:-)
0

LVL 15

Expert Comment

ID: 6948713
OOPS, small looping error "0 To UBound(arr) - 1"    :-)

Option Explicit

Text1.Text = "Red Blue Blue Yellow Red Red Blue Green Red"
End Sub

Private Sub Text1_Change()
Dim arr1() As String, arr2() As String, i As Long

arr1 = Split(Text1.Text, " ")
arr2 = RemoveDupes(Split(Text1.Text, " "))

Caption = ""
For i = 0 To UBound(arr2)
Caption = Caption & arr2(i) & " "
Next
End Sub

Public Function RemoveDupes(arr As Variant) As Variant
Dim col As Collection, v As Variant, i As Long, arrResult() As String
On Error Resume Next
Set col = New Collection

' uses the fact that collection doesn't accept items with the same key
For i = 0 To UBound(arr)
If Err Then ' item already exists
Err.Clear
End If
Next

' copy from collection to array
ReDim arrResult(0 To col.Count - 1)
For i = 1 To col.Count
arrResult(i - 1) = col.Item(i)
Next

RemoveDupes = arrResult ' return array
End Function
0

Expert Comment

ID: 6948801
write this code

dim Index1 as integer
dim Index2 as integer
dim found as boolean

do while index1<=ubound(arr1)
found=false
if trim(arr1(index1))=trim(arr2(index2)then
found=true
else
index2=index2+1
end if
loop
redim preserve arr2(Ubound(arr2)+1)
arr2(Ubound(arr2)+1) =arr1(index1)
end if
index1=index1+1
loop

0

Author Comment

ID: 6949042
Hi experts

thanks for your successfull answers. they are all helpful but I prefer Bahnas's one because it is so short and simple

BUT I think that there is no need for this part :

for I = 1 to UBound (arr1)
sArr =sArr & arr1(I)
next

ray14
0

LVL 15

Expert Comment

ID: 6949138
What if first element is "red" and second element is "re"?
Instr will find "re" in sArr, and it won't be added.
0

LVL 15

Expert Comment

ID: 6949162
Here is Shorter version of my code:

' Form1, add textbox (Text = "Red Blue Blue Yellow Red Red Blue Green Red")
Option Explicit

Private Sub Text1_Change()
Caption = Join(RemoveDupes(Split(Text1.Text, " ")), " ")
End Sub

Function RemoveDupes(arr As Variant) As Variant
Dim col As New Collection, v As Variant, i As Long, arrR() As String
On Error Resume Next

For Each v In arr
Err.Clear
Next

ReDim arrR(0 To col.Count - 1)
For i = 1 To col.Count
arrR(i - 1) = col.Item(i)
Next
RemoveDupes = arrR
End Function
0

LVL 3

Expert Comment

ID: 6949766
thanks for the points
:-)
0

Author Comment

ID: 6954942
Thank you ameba for your continuous efforts , realy your comments are right and your solution is nice... I'll use it in my project.
One day I ask another question , if you help me I shall increase the points by + 50 points ... as for this question..

ray14
0

LVL 15

Expert Comment

ID: 6961471
Thanks, ray14, maybe that day is today  ;-)
0

## Featured Post

This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…