Question

我想在集合中添加项目列表，避免添加重复项。这是我在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功能。现在，您可以创建自己的函数来复制集合。

以下是仅添加唯一值的示例函数：

'===================================================
' ADDS ONLY UNIQUE ITEMS TO A COLLECTION
'===================================================
Public Function CollectionAddUnique(ByRef Target As Collection, Value As String) As Boolean

    Dim l As Long

    'SEE IF COLLECTION HAS ANY VALUES
    If Target.Count = 0 Then
        Target.Add Value
        Exit Function
    End If

    'SEE IF VALUE EXISTS IN COLLECTION
    For l = 1 To Target.Count
        If Target(l) = Value Then
            Exit Function
        End If
    Next l

    'NOT IN COLLECTION, ADD VALUE TO COLLECTION
    Target.Add Value
    CollectionAddUnique = True

End Function

以下是检查值是否存在的示例函数：

'===================================================
' CHECK'S TO SEE IF VALUE EXISTS
'===================================================
Public Function CollectionValueExists(Target As Collection, Value As String) As Boolean

    Dim l As Long

    'SEE IF VALUE EXISTS IN COLLECTION
    For l = 1 To Target.Count
        If Target(l) = Value Then
            CollectionValueExists = True
            Exit For
        End If
    Next l

End Function

使用函数是一种很好的方法，因为你现在可以在任何其他时间使用它们，所以你不必重复自己。

您的代码可以像下面这样简单：

Private Sub workingWithCollections()

    Dim Fruits As Collection
    Dim Cell As Range

    Set Fruits = New Collection

    For Each Cell In Range("A1", Range("A" & Rows.Count).End(xlUp))
        CollectionAddUnique Fruits, Cell.Value
    Next Cell

End Sub

Answer 2

另一种方法是使用脚本字典。这确实有一个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 3

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

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 4

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

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 5

这是我的

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 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

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

6 个答案: