Need function to return 2D array with duplicates eliminated.

[OaklandJim]

I have a two dimensional array, asData. The first dimension has two indexes and there is a variable number of entries in the second dimension. I want to return an array with duplicate entries eliminated. So, I hope for a function that returns an array with unique entries only (i.e., without the duplicated entries). In the example the duplicates are for Joe and Eddie.

Just so I am clear, the array returned includes four entries: Bob, Tamika, one entry for Joe, and one entry for Eddie.

asData(1, 1) = Bob
asData(2, 1) = 2234

asData(1, 2) = Joe
asData(2, 2) = 5432

asData(1, 3) = Tamika
asData(2, 3) = 9976

asData(1, 4) = Eddie
asData(2, 4) = 9872

asData(1, 5) = Joe
asData(2, 5) = 5432

asData(1, 6) = Eddie
asData(2, 6) = 9872

I've seen examples using dictionary functionality but user may not have the necessary reference so ideally the approach offered uses arrays only.

I really appreciate the assistance.

 

[johnnyL]

Book2
	A	B	C	D	E	F	G
1	Bob	Joe	Tamika	Eddie	Joe	Eddie
2	2234	5432	9976	9872	5432	9872
3
Sheet1

I've seen examples using dictionary functionality but user may not have the necessary reference so ideally the approach offered uses arrays only.

What do you mean by that?

Also, do you just want the final results in an array or did you want to print the results of the final array somewhere?

 

[kevin9999]

One suggestion...

Option Explicit
Sub OaklandJim()
    Dim asData(1 To 2, 1 To 6)
    
    asData(1, 1) = "Bob"
    asData(2, 1) = 2234
    
    asData(1, 2) = "Joe"
    asData(2, 2) = 5432
    
    asData(1, 3) = "Tamika"
    asData(2, 3) = 9976
    
    asData(1, 4) = "Eddie"
    asData(2, 4) = 9872
    
    asData(1, 5) = "Joe"
    asData(2, 5) = 5432
    
    asData(1, 6) = "Eddie"
    asData(2, 6) = 9872
    
    Dim ArrTemp, ArrOut, d As Object, i As Long
    ArrTemp = Application.Transpose(asData)
    
    Set d = CreateObject("scripting.dictionary")
    For i = LBound(ArrTemp, 1) To UBound(ArrTemp, 1)
        If Not d.exists(ArrTemp(i, 1)) Then
            d.Add Key:=ArrTemp(i, 1), Item:=ArrTemp(i, 2)
        End If
    Next i
    
    ReDim ArrOut(1 To d.Count, 1 To 2)
    For i = 0 To d.Count - 1
        ArrOut(i + 1, 1) = d.Keys()(i)
        ArrOut(i + 1, 2) = d.Items()(i)
    Next i
    
    'ArrOut is the new array of unique keys/items
    
    'To return the array to the sheet horizontally
    'Cells.ClearContents
    'Cells(1).Resize(2, UBound(ArrOut, 1)).Value = Application.Transpose(ArrOut)
    
    'To return the array to the sheet vertically
    'Cells.ClearContents
    'Cells(1).Resize(UBound(ArrOut, 1), 2).Value = ArrOut

End Sub

 

[kevin9999]

Another option that doesn't use a dictionary - but does require 365.

Option Explicit
Sub OaklandJim_V2()
    Dim asData(1 To 2, 1 To 6)
    
    asData(1, 1) = "Bob"
    asData(2, 1) = 2234
    
    asData(1, 2) = "Joe"
    asData(2, 2) = 5432
    
    asData(1, 3) = "Tamika"
    asData(2, 3) = 9976
    
    asData(1, 4) = "Eddie"
    asData(2, 4) = 9872
    
    asData(1, 5) = "Joe"
    asData(2, 5) = 5432
    
    asData(1, 6) = "Eddie"
    asData(2, 6) = 9872
    
    Dim ArrTemp, ArrOut, i As Long
    ArrTemp = Application.Transpose(asData)
    
    ArrOut = Application.WorksheetFunction.Unique(ArrTemp)
        
    'ArrOut is the new array of unique names/values
    
    'To return the array to the sheet horizontally
    'Cells.ClearContents
    'Cells(1).Resize(UBound(ArrOut, 2), UBound(ArrOut, 1)).Value = Application.Transpose(ArrOut)
    
    'To return the array to the sheet vertically
    'Cells.ClearContents
    'Cells(1).Resize(UBound(ArrOut, 1), UBound(ArrOut, 2)).Value = ArrOut
End Sub

 

[kevin9999]

My post #4 can be simplified further by returning the unique values in a single step. Again, needs 365 (or 2021) to access the Unique function.

Option Explicit
Sub OaklandJim_V3()
    Dim asData(1 To 2, 1 To 6)
    
    asData(1, 1) = "Bob"
    asData(2, 1) = 2234
    
    asData(1, 2) = "Joe"
    asData(2, 2) = 5432
    
    asData(1, 3) = "Tamika"
    asData(2, 3) = 9976
    
    asData(1, 4) = "Eddie"
    asData(2, 4) = 9872
    
    asData(1, 5) = "Joe"
    asData(2, 5) = 5432
    
    asData(1, 6) = "Eddie"
    asData(2, 6) = 9872
    
    Dim ArrOut
    ArrOut = Application.WorksheetFunction.Unique(Application.Transpose(asData))
    
    'ArrOut is the new array of unique names/values
    
    'To return the array to the sheet horizontally
    'Cells.ClearContents
    'Cells(1).Resize(UBound(ArrOut, 2), UBound(ArrOut, 1)).Value = Application.Transpose(ArrOut)
    
    'To return the array to the sheet vertically
    'Cells.ClearContents
    'Cells(1).Resize(UBound(ArrOut, 1), UBound(ArrOut, 2)).Value = ArrOut
    
End Sub