VBA - Remove both items from array when not unique

Question

Quick question that I've been struggling with. I have 2 arrays of different lengths that contain strings. I want to output a new array which removes BOTH the elements if a duplicate is detected. At the moment it only removes duplicates but leaves the original which is incorrect for what I am trying to accomplish.

E.g.

input = array ("cat","dog","mouse","cat")  
expected output =  array ("dog","mouse")  
actual output = array ("cat","dog","mouse")

Code is below:

Sub removeDuplicates(CombinedArray)
Dim myCol As Collection
Dim idx As Long
Set myCol = New Collection

On Error Resume Next

For idx = LBound(CombinedArray) To UBound(CombinedArray)
    myCol.Add 0, CStr(CombinedArray(idx))
    If Err Then
        CombinedArray(idx) = Empty
        dups = dups + 1
        Err.Clear
    ElseIf dups Then
        CombinedArray(idx - dups) = CombinedArray(idx)
        CombinedArray(idx) = Empty
    End If
Next

For idx = LBound(CombinedArray) To UBound(CombinedArray)
    Debug.Print CombinedArray(idx)
Next
removeBlanks (CombinedArray)
End Sub

Thanks for all help and support in advance.

Sort the array using bubble sort and then remove the duplicates :) — Siddharth Rout
– Siddharth Rout, Commented Jul 31, 2012 at 10:37
Hi Siddharth, Are bubble sort algorithms not for numerical values? — user1228891
– user1228891, Commented Jul 31, 2012 at 10:49
No it is not necessary :) You can Bubble Sort an array of any type. — Siddharth Rout
– Siddharth Rout, Commented Jul 31, 2012 at 10:50
In fact there is one more way without sorting and that is using a unique collection. — Siddharth Rout
– Siddharth Rout, Commented Jul 31, 2012 at 11:13
Thanks again for the feedback Siddhart, would a unique collection only remove the duplicates though? I need it to remove both the original and the duplicate if a duplicate is detected. — user1228891
– user1228891, Commented Jul 31, 2012 at 11:18

martin · Accepted Answer · 2012-07-31 12:23:37Z

2

What about using Scripting.Dictionary? Like this:

Function RemoveDuplicates(ia() As Variant)

Dim c As Object
Set c = CreateObject("Scripting.Dictionary")
Dim v As Variant
For Each v In ia
    If c.Exists(v) Then
        c(v) = c(v) + 1
    Else
        c.Add v, 1
    End If
Next

Dim out() As Variant
Dim nOut As Integer
nOut = 0

For Each v In ia
    If c(v) = 1 Then
        ReDim Preserve out(nOut) 'you will have to increment nOut first, if you have 1-based arrays
        out(nOut) = v
        nOut = nOut + 1
    End If
Next

RemoveDuplicates = out

End Function

answered Jul 31, 2012 at 12:23

martin

2,68024 silver badges29 bronze badges

Sign up to request clarification or add additional context in comments.

Comments

Siddharth Rout · Accepted Answer · 2012-07-31 11:59:49Z

Here is a quick example. Let me know if you get any errors.

Sub Sample()
    Dim inputAr(5) As String, outputAr() As String, temp As String
    Dim n As Long, i As Long

    inputAr(0) = "cat": inputAr(1) = "Hen": inputAr(2) = "mouse"
    inputAr(3) = "cat": inputAr(4) = "dog": inputAr(5) = "Hen"

    BubbleSort inputAr

    For i = 1 To UBound(inputAr)
        If inputAr(i) = inputAr(i - 1) Or inputAr(i) = temp Then
            inputAr(i - 1) = "": temp = inputAr(i): inputAr(i) = ""
        End If
    Next i

    n = 0
    For i = 1 To UBound(inputAr)
        If inputAr(i) <> "" Then
            n = n + 1
            ReDim Preserve outputAr(n)
            outputAr(n) = inputAr(i)
        End If
    Next i

    For i = 1 To UBound(outputAr)
        Debug.Print outputAr(i)
    Next i
End Sub

Sub BubbleSort(arr)
    Dim value As Variant
    Dim i As Long, a As Long, b As Long, c As Long

    a = LBound(arr): b = UBound(arr)

    Do
        c = b - 1
        b = 0
        For i = a To c
            value = arr(i)
            If (value > arr(i + 1)) Xor False Then
                arr(i) = arr(i + 1)
                arr(i + 1) = value
                b = i
            End If
        Next
    Loop While b
End Sub

EDIT

Another way without sorting

Sub Sample()
    Dim inputAr(5) As String, outputAr() As String
    Dim n As Long, i As Long, j As Long
    Dim RemOrg As Boolean

    inputAr(0) = "cat": inputAr(1) = "Hen": inputAr(2) = "mouse"
    inputAr(3) = "cat": inputAr(4) = "dog": inputAr(5) = "Hen"

    For i = 0 To UBound(inputAr)
        For j = 1 To UBound(inputAr)
            If inputAr(i) = inputAr(j) Then
                If i <> j Then
                    inputAr(j) = "": RemOrg = True
                End If
            End If
        Next
        If RemOrg = True Then
            inputAr(i) = ""
            RemOrg = False
        End If
    Next i

    n = 0
    For i = 0 To UBound(inputAr)
        If inputAr(i) <> "" Then
            n = n + 1
            ReDim Preserve outputAr(n)
            outputAr(n) = inputAr(i)
        End If
    Next i

    For i = 1 To UBound(outputAr)
        Debug.Print outputAr(i)
    Next i
End Sub

Hi Siddarth, great work on the examples!, works fine on the test data, but when I deploy it onto my actual data 20 records saying either "duplicate" or "unique" and another 25 saying the same, I see repeating elements? Are you able oto provide support please?

Collectives™ on Stack Overflow

VBA - Remove both items from array when not unique

2 Answers 2

Comments

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

Comments

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related