Sub RemoveDuplicate (Arr() As Integer)
Dim i As Integer
Dim k As Integer
k = LBound(Arr)
For i = LBound(Arr)+1 To UBound(Arr)
If Arr(k) <> Arr(i) Then
k = k + 1
Arr(k) = Arr(i)
End If
Next i
' Remove unused entries from the result array.
ReDim Preserve Arr(LBound(Arr) To k)
End Sub
Dim mem() As Integer
ReDim mem(0 To 6)
mem(0)=10
mem(1)=12
mem(2)=12
mem(3)=11
mem(4)=10
mem(5)=20
mem(6)=210
For i As Integer=LBound(mem) To UBound(mem)
Print i,mem(i)
Next
Print
Print
RemoveDuplicate(mem())
For i As Integer=LBound(mem) To UBound(mem)
Print i,mem(i)
Next
Sleep
aloberoger wrote:this procedure does not give the expected result
If you expected to remove all duplicates then that statement is correct.
I you take pen en paper and draw the row of numbers with 2 pointers i & k and run the algorithm manually, then you quickly see where it fails. The first number 10 is checked only once and never again. The 2 numbers 10 are never compared against each other because pointer k does not return to the beginning of the row where the first number 10 is.
' This one works
#Include once "F:\Basic\LZLE_.bi"
Dim MyList As List
Dim As Integer k=0, i=0, keycount=0, Arr()
Redim Arr(10)
For i=0 to 10 : Arr(i)=100+i : Next i
Arr(7)=102
For i = LBound(Arr) To UBound(Arr)
If MyList.HashTag(Str(Arr(i)))=1 Then
Print "Duplicate found on " & MyList.HashTag
k+=1
Else
keycount+=1
MyList.RwTag1(Str(i-k))
End If
Next i
MyList.Root
While MyList.KeyStep
' ? "HashTag=" & MyList.HashTag & " Tag1=" & MyList.Tag(1)
Arr(Cint(MyList.Tag(1)))=Cint(MyList.HashTag) 'Use the required type conversion
Wend
Redim Preserve Arr( LBound(Arr) To LBound(Arr)+keycount-1)
For i=LBound(Arr) To Ubound(Arr)
? "i=" & i & " Arr(i)=" & Arr(i)
Next i
sleep
Short algo. easy to use. added k.
Last edited by Lost Zergling on Mar 09, 2021 9:57, edited 2 times in total.
#macro cleanup(a,b)
Redim b(0)
Scope
Dim As Long flag
For n1 As Long=Lbound(a) To Ubound(a)
flag=0
For n2 As Long=n1+1 To Ubound(a)
If a(n1)=a(n2) Then flag=1:Exit For
Next n2
If flag=0 Then
Redim Preserve b(1 To Ubound(b)+1)
b(Ubound(b))=a(n1)
End If
Next n1
Var lb=Lbound(a)
Redim Preserve b(lb To Ubound(b)+lb-1)
End Scope
#endmacro
#macro show(a)
For n As Integer=Lbound(a) To Ubound(a)
Print n,a(n)
Next
Print
#endmacro
Dim mem() As Integer
Redim mem(0 To 6)
mem(0)=10
mem(1)=12
mem(2)=12
mem(3)=11
mem(4)=10
mem(5)=20
mem(6)=210
Redim result() As Integer
cleanup(mem,result)
show(result)
Dim As String s(3 To ...)={"a","b","c","a","b","c","d","f","f","f","q"}
Redim As String resultS()
cleanup(s,resultS)
show(resultS)
Redim As Long L2(-3 To 2000000)
For n As Long=-3 To Ubound(L2)
L2(n)=Int(Rnd*10)
Next
Redim As Long Lanswer()
cleanup(L2,Lanswer)
Print
show(LAnswer)
Sleep
Sub RemoveDuplicate (Arr() As Integer)
Dim As Integer i, j
Do
For i = LBound(Arr) To UBound(Arr) - 1
For j = i + 1 To Ubound(Arr)
If Arr(i) = Arr(j) Then
Swap Arr(j), Arr(Ubound(Arr))
Redim Preserve Arr(LBound(Arr) To Ubound(Arr) - 1)
Continue Do
End If
Next j
Next i
Loop Until i = Ubound(Arr)
End Sub
Last edited by fxm on Mar 08, 2021 22:56, edited 2 times in total.
in general for the automated drawing there are often duplicate values that can draw a text for example twice, when one wants to perform operations on the text, only one text is selected. and ...
the method of fxm is correct, but not suitable for large loops
on the other hand the dodicat method is optimized but does not give the expected result for the following case:
Dim mem () As Long
Redim mem (0 to 6)
mem (0) = 10
mem (1) = 12
mem (2) = 12
mem (3) = 11
mem (4) = 10
mem (5) = 20
mem (6) = 210
the result must be:
mem (0) = 10
mem (1) = 12
mem (2) = 11
mem (3) = 20
mem (4) = 210
Sub RemoveDuplicate (Arr() As Integer)
Dim As Integer i, j, k
k = Ubound(Arr)
i = LBound(Arr)
Do While i < k
j = i + 1
Do While j <= k
If Arr(i) = Arr(j) Then
Swap Arr(j), Arr(k)
k = k - 1
Else
j = j + 1
End If
Loop
i = i + 1
Loop
Redim Preserve Arr(LBound(Arr) To k)
End Sub
Sub RemoveDuplicate (Arr() As Integer)
Dim As Integer i, j, k
k = Ubound(Arr)
i = LBound(Arr)
Do While i < k
j = i + 1
Do While j <= k
If Arr(i) = Arr(j) Then
Arr(j) = Arr(k)
k = k - 1
Else
j = j + 1
End If
Loop
i = i + 1
Loop
Redim Preserve Arr(LBound(Arr) To k)
End Sub
Sub RemoveDuplicate OverLoad (Arr() As String,Lanswer()As String)
Redim Lanswer(0)
Scope
Dim As Long flag
For n1 As Long=Lbound(Arr) To Ubound(Arr)
flag=0
For n2 As Long=n1+1 To Ubound(Arr)
If Arr(n1)=Arr(n2) Then flag=1:Exit For
Next n2
If flag=0 Then
ReDim Preserve Lanswer(1 To Ubound(Lanswer)+1)
Lanswer(Ubound(Lanswer))=Arr(n1)
End If
Next n1
Var lb=Lbound(Arr)
ReDim Preserve Lanswer(lb To Ubound(Lanswer)+lb-1)
End Scope
End Sub
Sub Remove_Duplicate (Arr() As String)
Dim As Integer i, j, k
k = Ubound(Arr)
i = LBound(Arr)
Do While i < k
j = i + 1
Do While j <= k
If Arr(i) = Arr(j) Then
Arr(j) = Arr(k)
k = k - 1
Else
j = j + 1
End If
Loop
i = i + 1
Loop
Redim Preserve Arr(LBound(Arr) To k)
End Sub
Print "-----3------"
Dim As String s(0 To ...)={"a","b","c","a","b","c","d","f","f","f","q"}
Redim As String resultS()
RemoveDuplicate(s(),resultS())
For n As Integer=Lbound(resultS) To Ubound(resultS)
Print n,resultS(n)
Next
Print
Print "-----4------"
Dim As String ss()'={"a","b","c","a","b","c","d","f","f","f","q"}
ReDim ss(0 To 10)
ss(0)= "a"
ss(1)="b"
ss(2)="c"
ss(3)="a"
ss(4)="b"
ss(5)="c"
ss(6)="d"
ss(7)="f"
ss(8)="f"
ss(9)="f"
ss(10)="q"
Remove_Duplicate(ss())
For n As Integer=Lbound(sS) To Ubound(sS)
Print n,sS(n)
Next
Print
Sleep
Sub Remove_Duplicate (Arr() As String)
Dim As Integer i, j, k, l
k = Ubound(Arr)
i = LBound(Arr)
Do While i < k
j = i + 1
Do While j <= k
If Arr(i) = Arr(j) Then
For l = j To k - 1
Arr(l) = Arr(l + 1)
Next l
k = k - 1
Else
j = j + 1
End If
Loop
i = i + 1
Loop
Redim Preserve Arr(LBound(Arr) To k)
End Sub