• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 192
  • Last Modified:

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
0
ray14
Asked:
ray14
  • 5
  • 3
  • 2
  • +2
1 Solution
 
mlmccCommented:
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
  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
0
 
amebaCommented:
' 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.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
        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
0
 
BahnassCommented:
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
The 14th Annual Expert Award Winners

The results are in! Meet the top members of our 2017 Expert Awards. Congratulations to all who qualified!

 
BahnassCommented:
too slow
:-)
0
 
amebaCommented:
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.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)
        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
0
 
RAJzCommented:
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(arr2(index2)then
         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

0
 
ray14Author Commented:
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
 
amebaCommented:
What if first element is "red" and second element is "re"?
Instr will find "re" in sArr, and it won't be added.
0
 
amebaCommented:
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
       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
0
 
BahnassCommented:
thanks for the points
:-)
0
 
ray14Author Commented:
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
 
amebaCommented:
Thanks, ray14, maybe that day is today  ;-)
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 5
  • 3
  • 2
  • +2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now