Remove duplicates from array using VBA

前端 未结 8 787
猫巷女王i
猫巷女王i 2020-11-27 22:12

Assume I have a block of data in Excel 2010, 100 rows by 3 columns.

Column C contains some duplicates, say it starts off as

1, 1, 1, 2, 3, 4,

相关标签:
8条回答
  • 2020-11-27 23:14

    An improvement on @RBILLC and @radoslav006 answers, this version searches the array with the duplicates removed for existing values so it searchs less values to find a duplicate.

    Public Function RemoveDuplicatesFromArray(sourceArray As Variant)
        Dim duplicateFound As Boolean
        Dim arrayIndex As Integer, i As Integer, j As Integer
        Dim deduplicatedArray() As Variant
        
        arrayIndex = -1
        deduplicatedArray = Array(1)
    
        For i = LBound(sourceArray) To UBound(sourceArray)
            duplicateFound = False
    
            For j = LBound(deduplicatedArray) To UBound(deduplicatedArray)
                If sourceArray(i) = deduplicatedArray(j) Then
                    duplicateFound = True
                    Exit For
                End If
            Next j
    
            If duplicateFound = False Then
                arrayIndex = arrayIndex + 1
                ReDim Preserve deduplicatedArray(arrayIndex)
                deduplicatedArray(arrayIndex) = sourceArray(i)
            End If
        Next i
    
        RemoveDuplicatesFromArray = deduplicatedArray
    End Function
    
    0 讨论(0)
  • 2020-11-27 23:19

    Remove duplicates (plus related row items) from array

    As OP wanted a VBA solution close to RemoveDuplicates, I demonstrate an array approach using a ►dictionary to get not the unique items per se (dict.keys), but the related row indices of first occurrencies (dict.items).

    These are used to retain the whole row data via procedure LeaveUniques profiting from the advanced possibilities of the ►Application.Index() function - c.f. Some peculiarities of the the Application.Index function

    Example Call

    Sub ExampleCall()
    '[0]define range and assign data to 1-based 2-dim datafield
        With Sheet1                   ' << reference to your project's sheet Code(Name)
            Dim lastRow: lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
            Dim rng:  Set rng = .Range("C2:E" & lastRow)
        End With
        Dim data: data = rng        ' assign data to 2-dim datafield
    '[1]get uniques (column 1) and remove duplicate rows
        LeaveUniques data           ' << call procedure LeaveUniques (c.f. RemoveDuplicates)
    '[2]overwrite original range
        rng.Clear
        rng.Resize(UBound(data), UBound(data, 2)) = data
    End Sub
    

    Procedure LeaveUniques

    Sub LeaveUniques(ByRef data As Variant, Optional ByVal colNum As Long = 1)
    'Purpose: procedure removes duplicates of given column number in entire array
        data = Application.Index(data, uniqueRowIndices(data, colNum), nColIndices(UBound(data, 2)))
    End Sub
    

    Help functions to LeaveUniques

    Function uniqueRowIndices(data, Optional ByVal colNum As Long = 1)
    'Purpose: return data index numbers referring to uniques
    'a) set late bound dictionary to memory
        Dim dict As Object
        Set dict = CreateObject("Scripting.Dictionary")
    'b) slice e.g. first data column (colNum = 1)
        Dim colData
        colData = Application.Index(data, 0, colNum)
    'c) fill dictionary with uniques referring to first occurencies
        Dim i As Long
        For i = 1 To UBound(colData)
            If Not dict.exists(dict(colData(i, 1))) Then dict(colData(i, 1)) = i
        Next
    'd) return 2-dim array of valid unique 1-based index numbers
        uniqueRowIndices = Application.Transpose(dict.items)
    End Function
    
    Function nColIndices(ByVal n As Long)
    'Purpose: return "flat" array of n column indices, e.g. for n = 3 ~> Array(1, 2, 3)
        nColIndices = Application.Transpose(Evaluate("row(1:" & n & ")"))
    End Function
    
    
    0 讨论(0)
提交回复
热议问题