检查集合或数组中是否存在值，如果不存在，则添加[重复]

Question

这个问题在这里已经有了答案：

VBA 有字典结构吗？ (11 个回答)

3年前关闭。

我想将项目列表添加到集合中并避免添加重复项。 这是我在 A 列中的列表

Apple
Orange
Pear
Orange
Orange
Apple
Carrot

我只想补充

Apple 
Orange 
Pear 
Carrot

这是我想出的，它有效，但它并不漂亮。

dim coll as New Collection

ln = Cells(Rows.Count, 1).End(xlUp).Row

coll.Add (Cells(1, 1).Value)   'Add first item manually to get it started
For i = 1 To ln

    addItem = True    'Assume it's going to be added until proven otherwise

    For j = 1 To coll.Count    'Loop through the collection

        'If we ever find the item in the collection
        If InStr(1, Cells(i, 1), coll(j), vbTextCompare) > 0 Then                     

            addItem = False     'set this bool false

        End If

    Next j

    If addItem = True Then   'It never got set to false, so add it

        coll.Add (Cells(i, "A").Value)

    End If

Next i

有没有更简单的方法来做到这一点？ 最好是这样的

If Not coll.Contains(someValue) Then
    coll.Add (someValue)
End If

Answer 1

我强烈推荐使用字典，因为它们有很多集合没有的特性，包括Exists函数。

话虽如此，创建一个函数会很容易，它首先检查集合中是否存在一个值，然后另一个函数只在值不存在时添加它。

检查值是否存在

要查看它是否已经存在，只需使用一个简单的 for 循环。 如果该值存在，则返回 true 并退出函数。

' Check to see if a value is in a collection.
' Functional approcah to mimic dicitonary `exists` method.
Public Function CollectionValueExists(ByRef target As Collection, value As Variant) As Boolean
    Dim index As Long
    For index = 1 To target.Count
        If target(index) = value Then
            CollectionValueExists = True
            Exit For
        End If
    Next index
End Function

添加唯一值

使用新函数CollectionValueExists就像一个if条件语句一样简单，以if是否应该添加它。

为了使这更加动态，您还可以使用ParamArray来允许通过一次调用添加多个值。 只需循环每个值，看看是否需要添加。 这不适用于您的示例，但可灵活用于其他用途。

' Adds unique values to a collection.
' @note this mutates the origianal collection.
Public Function CollectionAddUnique(ByRef target As Collection, ParamArray values() As Variant) As Boolean
    Dim index As Long
    For index = LBound(values) To UBound(values)
        If Not CollectionValueExists(target, values(index)) Then
            CollectionAddUnique = True
            target.Add values(index)
        End If
    Next index
End Function

演示

综上所述，您可以简单地循环您的范围并调用新函数。

Private Sub demoAddingUniqueValuesToCollection()
    Dim fruits As Collection
    Set fruits = New Collection
    
    Dim cell As Range
    For Each cell In Range("A1", Range("A" & Rows.Count).End(xlUp))
        CollectionAddUnique fruits, cell.value
    Next cell
End Sub

Answer 2

这将填充唯一唯一的集合：

Dim coll As New Collection
Dim ln As Long
ln = Cells(Rows.count, 1).End(xlUp).Row

Dim i As Long
For i = 1 To ln
    On Error Resume Next
        coll.Add Cells(i, 1).Value, Cells(i, 1).Value
    On Error GoTo 0
Next i

Dim ech
For Each ech In coll
    Debug.Print ech
Next ech

Answer 3

这是我的

Option Explicit


Sub Test()

    Dim Ln
    Ln = Cells(Rows.Count, 1).End(xlUp).Row

    Dim rngInput As Excel.Range
    Set rngInput = Range(Cells(1, 1), Cells(Ln, 1)) '* really should qualify with a sheet otherwise you're at the mercy of activesheet

    Dim dicUnique As Scripting.Dictionary '* requires Tools->Reference : Microsoft Scripting Runtime
    Set dicUnique = UniqueCellContents(rngInput)

    Dim vOutput As Variant
    vOutput = dicUnique.Keys

    Dim rngOutput As Excel.Range
    Set rngOutput = Range(Cells(1, 3), Cells(dicUnique.Count, 3))  '* really should qualify with a sheet otherwise you're at the mercy of activesheet
    rngOutput.Value = Application.Transpose(vOutput)

'
'    Dim coll As New Collection
'
'    Ln = Cells(Rows.Count, 1).End(xlUp).Row
'
'    coll.Add (Cells(1, 1).Value)   'Add first item manually to get it started
'    For i = 1 To Ln
'
'        AddItem = True    'Assume it's going to be added until proven otherwise
'
'        For j = 1 To coll.Count    'Loop through the collection
'
'            'If we ever find the item in the collection
'            If InStr(1, Cells(i, 1), coll(j), vbTextCompare) > 0 Then
'
'                AddItem = False     'set this bool false
'
'            End If
'
'        Next j
'
'        If AddItem = True Then   'It never got set to false, so add it
'
'            coll.Add (Cells(i, "A").Value)
'
'        End If
'
'    Next i

End Sub

Function UniqueCellContents(ByVal rngInput As Excel.Range) As Scripting.Dictionary
    Dim dic As Scripting.Dictionary '* requires Tools->Reference : Microsoft Scripting Runtime
    Set dic = New Scripting.Dictionary

    Dim vValues As Variant
    vValues = (rngInput)

    If Not IsArray(vValues) Then
        dic.Add vValues, 0
    Else
        Dim vLoop As Variant
        For Each vLoop In vValues
            If Not dic.Exists(vLoop) Then
                dic.Add vLoop, 0
            End If

        Next vLoop

    End If

    Set UniqueCellContents = dic

End Function

Answer 4

另一种方法是使用脚本词典。 这确实有一个 Exists 方法 - 下面的代码实际上绕过了这个方法，如果键已经存在，它将覆盖现有项目。

Sub x()

Dim oDic As Object, r As Range

Set oDic = CreateObject("Scripting.Dictionary")

For Each r In Range("A1:A7")
    oDic(r.Value) = r.Row
    ' if not odic.exists(r.value) then ...
Next r

MsgBox Join(oDic.keys, ",")

End Sub

Answer 5

如果您想检查集合中某个项目是否存在（因为它们没有字典的存在功能），那么我使用以下代码段

Public Function InCollection(Col As Collection, key As String) As Boolean
  Dim var As Variant
  Dim errNumber As Long

  InCollection = False
  Set var = Nothing

  Err.clear
  On Error Resume Next
    var = Col.Item(key)
    errNumber = CLng(Err.Number)
  On Error GoTo 0

  '5 is not in, 0 and 438 represent incollection
  If errNumber = 5 Then ' it is 5 if not in collection
    InCollection = False
  Else
    InCollection = True
  End If

End Function

使用如：

If InCollection(CollectionName,IDKey) Then

Else

End If

Answer 6

其它的办法

Dim coll As New Collection
Dim i As Long

For i = 1 To Cells(Rows.count, 1).End(xlUp).Row
    If Worksheetfunction.CountIf(Cells(1,1).Resize(i), Cells(i, 1).Value) = 1 Then coll.Add Cells(i, 1).Value, Cells(i, 1).Value
Next

或者

Dim coll As New Collection
Dim oldValues As Variant
Dim cell As Range

With Range(Cells(1, 1), Cells(Rows.count, 1).End(xlUp))
    oldValues = .Value
    .RemoveDuplicates Columns:=1, Header:=xlNo
    For Each cell In .SpecialCells(xlCellTypeConstants)
        coll.Add cell.Value, cell.Value
    Next
    .Value = oldValues
End With