Prev: Lookup Cell Interior
Next: export data between spreadsheets
From: Dan Thompson on 28 May 2010 14:49
I have recently found a function on the interent that will remove duplicate
values within any array. It works just fine for a single dimensional array
but I would like to edit and change the code to work for Multi-Dimensional
array to support a minimum of 2 dimentional arrays. I only need it to find
any duplicate values within the first dimension of the array and than remove
any values corisponding to the same element number that the duplicate value
was found in the 1st dimention of the array and remove them from the 2nd and
3rd dimention of the array as well.

For example:
MyArray(1,2)
----------------------
| 0 | 0 | Hello |
| 1 | 0 | XX |
| 0 | 1 | Bye |
| 1 | 1 | YY |
| 0 | 2 | Hello |
| 1 | 2 | ZZ |
----------------------
So how it should work on the above sample array is that it would find look
for duplicate value in 1st dimention and find the value in 0,2 is a duplicate
of 0,0 and it will remove the 0,2 value and than since it found a duplicate
value in 0,2 and removed it, It would also than remove any value in same
corrisponding element row from the other dimentions i the case of the sample
above it would also not only remove 0,2 but it would remove 1,2 as well even
though 1,2 is not a duplicate
value.

Here is my currently working function based on just single dimetional arrays

Public Function RemoveDuplicates(ByRef SourceArray As Variant)
Dim Values As Collection
Dim Value As Variant
Dim Index1 As Long
Dim Index2 As Long

Set Values = New Collection
Index2 = LBound(SourceArray)
On Error Resume Next
For Index1 = LBound(SourceArray) To UBound(SourceArray)
Value = Empty
Value = Values(VarType(SourceArray(Index1)) & "|" & SourceArray(Index1))
If IsEmpty(Value) And Not Len(SourceArray(Index1)) = 0 Then
Values.Add SourceArray(Index1), VarType(SourceArray(Index1)) & "|"
& SourceArray(Index1)
SourceArray(Index2) = SourceArray(Index1)
Index2 = Index2 + 1
End If
Next Index1
On Error GoTo 0
If Index2 = 1 Then
SourceArray = Empty
Else
ReDim Preserve SourceArray(LBound(SourceArray) To Index2 - 1)
End If

End Function

I hope someone can help me find a solution.

Thanks,
Dan Thompson
From: Dave Peterson on 28 May 2010 18:40
So with this data, you'd end up with 2 rows:

----------------------
| 0 | 0 | Hello |
| 1 | 0 | XX |
----------------------

If that's correct, then this worked ok for me. I don't think it would scale for
more than 2 dimensions, though.

All I did was let each entry in the collection hold that row (an array).

Option Explicit
Sub testme()

'| 0 | 0 | Hello |
'| 1 | 0 | XX |
'| 0 | 1 | Bye |
'| 1 | 1 | YY |
'| 0 | 2 | Hello |
'| 1 | 2 | ZZ |

Dim myArr(0 To 5, 0 To 2) As Variant
Dim myArrCols(0 To 2) As Variant
Dim cCtr As Long
Dim rCtr As Long

Dim myColl As Collection
Dim ColCtr As Long

Dim myNewArr As Variant

'just creating the test array
myArrCols(0) = Array(0, 1, 0, 1, 0, 1)
myArrCols(1) = Array(0, 0, 1, 1, 2, 2)
myArrCols(2) = Array("hello", "xx", "bye", "yy", "hello", "zz")

For cCtr = LBound(myArrCols) To UBound(myArrCols)
For rCtr = LBound(myArrCols(cCtr)) To UBound(myArrCols(cCtr))
myArr(rCtr, cCtr) = myArrCols(cCtr)(rCtr)
Next rCtr
Next cCtr


'now the real work
Set myColl = New Collection

On Error Resume Next
For rCtr = LBound(myArr, 1) To UBound(myArr, 1)
myColl.Add Application.Index(myArr, rCtr + 1, 0), CStr(myArr(rCtr, 0))
Next rCtr
On Error GoTo 0

If myColl.Count = 0 Then
MsgBox "no data!"
Else
ReDim myNewArr(LBound(myArr, 1) _
To LBound(myArr, 1) + myColl.Count - 1, _
LBound(myArr, 2) To UBound(myArr, 2))

iCtr = 1
For rCtr = LBound(myNewArr, 1) To UBound(myNewArr, 1)
'this didn't work
'myNewArr(rCtr) = myColl.Item(iCtr)
'so I had to loop
ColCtr = 1
For cCtr = LBound(myNewArr, 2) To UBound(myNewArr, 2)
myNewArr(rCtr, cCtr) = myColl.Item(iCtr)(ColCtr)
ColCtr = ColCtr + 1
Next cCtr
iCtr = iCtr + 1
Next rCtr
End If

'and to prove that it worked ok
For rCtr = LBound(myNewArr, 1) To UBound(myNewArr, 1)
For cCtr = LBound(myNewArr, 2) To UBound(myNewArr, 2)
Debug.Print rCtr & "." & cCtr & ":" & myNewArr(rCtr, cCtr)
Next cCtr
Next rCtr

End Sub


Dan Thompson wrote:
>
> I have recently found a function on the interent that will remove duplicate
> values within any array. It works just fine for a single dimensional array
> but I would like to edit and change the code to work for Multi-Dimensional
> array to support a minimum of 2 dimentional arrays. I only need it to find
> any duplicate values within the first dimension of the array and than remove
> any values corisponding to the same element number that the duplicate value
> was found in the 1st dimention of the array and remove them from the 2nd and
> 3rd dimention of the array as well.
>
> For example:
> MyArray(1,2)
> ----------------------
> | 0 | 0 | Hello |
> | 1 | 0 | XX |
> | 0 | 1 | Bye |
> | 1 | 1 | YY |
> | 0 | 2 | Hello |
> | 1 | 2 | ZZ |
> ----------------------
> So how it should work on the above sample array is that it would find look
> for duplicate value in 1st dimention and find the value in 0,2 is a duplicate
> of 0,0 and it will remove the 0,2 value and than since it found a duplicate
> value in 0,2 and removed it, It would also than remove any value in same
> corrisponding element row from the other dimentions i the case of the sample
> above it would also not only remove 0,2 but it would remove 1,2 as well even
> though 1,2 is not a duplicate
> value.
>
> Here is my currently working function based on just single dimetional arrays
>
> Public Function RemoveDuplicates(ByRef SourceArray As Variant)
> Dim Values As Collection
> Dim Value As Variant
> Dim Index1 As Long
> Dim Index2 As Long
>
> Set Values = New Collection
> Index2 = LBound(SourceArray)
> On Error Resume Next
> For Index1 = LBound(SourceArray) To UBound(SourceArray)
> Value = Empty
> Value = Values(VarType(SourceArray(Index1)) & "|" & SourceArray(Index1))
> If IsEmpty(Value) And Not Len(SourceArray(Index1)) = 0 Then
> Values.Add SourceArray(Index1), VarType(SourceArray(Index1)) & "|"
> & SourceArray(Index1)
> SourceArray(Index2) = SourceArray(Index1)
> Index2 = Index2 + 1
> End If
> Next Index1
> On Error GoTo 0
> If Index2 = 1 Then
> SourceArray = Empty
> Else
> ReDim Preserve SourceArray(LBound(SourceArray) To Index2 - 1)
> End If
>
> End Function
>
> I hope someone can help me find a solution.
>
> Thanks,
> Dan Thompson

--

Dave Peterson
 | 
Pages: 1
Prev: Lookup Cell Interior
Next: export data between spreadsheets