Question

我有这个功能，在删除vb6中的重复项时速度很慢

Function FilterDuplicates(Arr As Variant) As Long
    Dim col      As Collection, index As Long, dups As Long
    Set col = New Collection

    On Error Resume Next

    For index = LBound(Arr) To UBound(Arr)
        ' build the key using the array element
        ' an error occurs if the key already exists
        col.Add 0, CStr(Arr(index))
        If Err Then
            ' we've found a duplicate
            Arr(index) = Empty
            dups = dups + 1
            Err.Clear
        ElseIf dups Then
            ' if we've found one or more duplicates so far
            ' we need to move elements towards lower indices
            Arr(index - dups) = Arr(index)
            Arr(index) = Empty
        End If
    Next

    ' return the number of duplicates
    FilterDuplicates = dups

End Function

我需要优化此功能才能更快地运行，请帮助

Answer 1

Function FilterDuplicates(Arr As Variant) As Long
    Dim col      As Dictionary, index As Long, dups As Long
    Set col = New Dictionary

    On Error Resume Next

    For index = LBound(Arr) To UBound(Arr)
        ' build the key using the array element
        ' an error occurs if the key already exists
        If col.Exists(Arr(index)) Then
            ' we've found a duplicate
            dups = dups + 1
        Else
            Call col.Add(Arr(index), vbNullstring)
        End If
    Next

    Dim newArr(1 to col.Keys.Count) As Variant
    Dim newIndex As Long
    For index = LBound(Arr) To UBound(Arr)
        If col(Arr(index)) = vbNullstring Then
            newIndex = newIndex + 1
            col(Arr(index)) = "Used"
            newArr(newIndex) = Arr(index)
        End If
    Next index
    Arr = newArr

    ' return the number of duplicates
    FilterDuplicates = dups

End Function

Answer 2

使用String串联（对于大型数组来说不太快）和InStrB（）函数：

Function FilterDuplicates(arr As Variant) As Long
Dim item As String, dups As Long, strArray As String

For i = LBound(arr) To UBound(arr)
    item = arr(i)
    If lenb(item) <> 0 Then
      If InStrB(1, strArray, item) = 0 Then
        strArray = strArray & item & ";"
      Else
        dups = dups + 1
      End If
    End If
Next i

FilterDuplicates = dups
End Function

更快地删除重复vb6

2 个答案: