ray14
asked on
create an unique array
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)
Thanx in advance.
ray14
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)
Thanx in advance.
ray14
' Form1 code, add textbox
Option Explicit
Private Sub Form_Load()
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.Te
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
col.Add arr(i), "k" & arr(i)
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
Option Explicit
Private Sub Form_Load()
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.Te
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
col.Add arr(i), "k" & arr(i)
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
too slow
:-)
:-)
OOPS, small looping error "0 To UBound(arr) - 1" :-)
' Form1 code, add textbox
Option Explicit
Private Sub Form_Load()
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.Te
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)
col.Add arr(i), "k" & arr(i)
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
' Form1 code, add textbox
Option Explicit
Private Sub Form_Load()
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.Te
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)
col.Add arr(i), "k" & arr(i)
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
write this code
dim Index1 as integer
dim Index2 as integer
dim found as boolean
do while index1<=ubound(arr1)
found=false
dowhile index2 <=ubound(arr2)and not found
if trim(arr1(index1))=trim(ar
found=true
else
index2=index2+1
end if
loop
if not found then
redim preserve arr2(Ubound(arr2)+1)
arr2(Ubound(arr2)+1) =arr1(index1)
end if
index1=index1+1
loop
dim Index1 as integer
dim Index2 as integer
dim found as boolean
do while index1<=ubound(arr1)
found=false
dowhile index2 <=ubound(arr2)and not found
if trim(arr1(index1))=trim(ar
found=true
else
index2=index2+1
end if
loop
if not found then
redim preserve arr2(Ubound(arr2)+1)
arr2(Ubound(arr2)+1) =arr1(index1)
end if
index1=index1+1
loop
ASKER
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
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
What if first element is "red" and second element is "re"?
Instr will find "re" in sArr, and it won't be added.
Instr will find "re" in sArr, and it won't be added.
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(Tex
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
col.Add v, "k" & v
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
' Form1, add textbox (Text = "Red Blue Blue Yellow Red Red Blue Green Red")
Option Explicit
Private Sub Text1_Change()
Caption = Join(RemoveDupes(Split(Tex
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
col.Add v, "k" & v
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
thanks for the points
:-)
:-)
ASKER
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
One day I ask another question , if you help me I shall increase the points by + 50 points ... as for this question..
ray14
Thanks, ray14, maybe that day is today ;-)
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
if not found
redeimension arr2 to current size +1
set max element of arr2 to arr1(x)
arr2 now has the unique values in arr1
mlmcc