如何更改集合项的值

还可以编写一个（公共）函数来对集合进行更新。

public function updateCollectionWithStringValue(coll as Collection, key as string, value as string) as collection
    coll.remove key
    coll.add value, key
    set updateCollectionWithStringValue = coll
end function

您可以通过以下方式调用此函数：

set coll = updateCollectionWithStringValue(coll, "String1","myString")

然后，您有一个可以调用的衬里。

你不能使用这个参数来满足这个要求吗？Before

例：

Option Explicit

Sub TestProject()
    Dim myStrings As New Collection

    myStrings.Add item:="Text 1"
    myStrings.Add item:="Text 2"
    myStrings.Add item:="Text 3"

    ' Print out the content of collection "myStrings"
    Debug.Print "--- Initial collection content ---"
    PrintCollectionContent myStrings
    ' Or with the "Call" keyword: Call PrintCollectionContent(myStrings)
    Debug.Print "--- End Initial collection content ---"

    ' Now we want to change "Text 2" into "New Text"
    myStrings.Add item:="New Text", Before:=2 ' myStrings will now contain 4 items
    Debug.Print "--- Collection content after adding the new content ---"
    ' Print out the 'in-between' status of collection "myStrings" where we have
    ' both the new string and the string to be replaced still in.
    PrintCollectionContent myStrings
    Debug.Print "--- End Collection content after adding the new content ---"

    myStrings.Remove 3
    ' Print out the final status of collection "myStrings" where the obsolete 
    ' item is removed
    Debug.Print "--- Collection content after removal of the old content ---"
    PrintCollectionContent myStrings
    Debug.Print "--- End Collection content after removal of the old content ---"

End Sub

Private Sub PrintCollectionContent(ByVal myColl As Variant)
    Dim i as Integer

    For i = 1 To myColl.Count()
        Debug.Print myColl.Item(i)
    Next i
End Sub

这不应该完成这项工作吗？

只需循环集合并将新值添加到新集合中即可...

function prep_new_collection(my_old_data as collection) as collection

dim col_data_prep as new collection

for i = 1 to my_old_data.count

if my_old_data(i)(0)= "whatever" then

  col_data_prep.add array("NULL", my_old_data(i)(1))

else

 col_data_prep.add array(my_old_data(i)(0), my_old_data(i)(1))

end if

next i

 set prep_new_collection = col_data_prep

end function

我刚刚遇到了同样的问题，想在这里为任何可能需要它的人发布我的解决方案。我的解决方案是制作一个名为 EnhancedCollection 的类，该类具有更新函数。将此代码保存到名为 EnhancedCollection.cls 的文件中，然后导入到项目中。

    VERSION 1.0 CLASS
    BEGIN
      MultiUse = -1  'True
    END
    Attribute VB_Name = "EnhancedCollection"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = False
    Attribute VB_Exposed = False
    Option Explicit
    
    Private data As New Collection
       
    '=================================ADD
    
    If IsMissing(key) Then
        If IsMissing(before) Then
            If IsMissing(after) Then
                data.Add Value
            Else
                data.Add Value, , , after
            End If
        Else
            data.Add Value, , before
        End If
    ElseIf key = "TEMP_ITEM" Then
        Exit Sub
    Else
        If IsMissing(before) Then
            If IsMissing(after) Then
                data.Add Value, key
            Else
                data.Add Value, key, , after
            End If
        Else
            data.Add Value, key, before
        End If
    End If
End Sub
'=================================REMOVE

Sub Remove(key As Variant)
    data.Remove key
End Sub

    '=================================COUNT
    
    Function Count() As Integer
        Count = data.Count
    End Function
    '=================================ITEM
    
    Function Item(key As Variant) As Variant
    'This is the default Function of the class
    Attribute Item.VB_Description = "returns the item"
    Attribute Item.VB_UserMemId = 0
    On Error GoTo OnError
        If VarType(key) = vbString Or VarType(key) = vbInteger Then
            Item = data.Item(key)
        End If
        Exit Function
    OnError:
        Item = Null
    End Function
    '=================================Update
    
    Function Update(key As Variant, Value As Variant) As Variant
    On Error GoTo OnError
        If VarType(key) = vbString Or VarType(key) = vbInteger Then
            data.Add "", "TEMP_ITEM", , key
            data.Remove key
            data.Add Value, key, "TEMP_ITEM"
            data.Remove "TEMP_ITEM"
        End If
        Exit Function
    OnError:
        Update = Null
    End Function

作为额外的好处，您可以随时添加更多功能。

这是一个有效的解决方案。Coll("String1") = "myString"

将对象添加到 VBA 集合时，将添加对象本身，而不是其值。这意味着，当对象位于集合中时，您可以更改该对象的属性。我创建了一个类模块，该模块将单个变体包装在类对象中，并将其作为其默认属性。将其保存到文件中，然后在 VBA 编辑器中保存。.Add.Value.clsFile > Import File

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsValue"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit
Private MyValue As Variant
Property Get Value() As Variant
    Attribute Value.VB_UserMemId = 0
    Value = MyValue
End Property
Property Let Value(v As Variant)
    Attribute Value.VB_UserMemId = 0
    MyValue = v
End Property

现在，此版本的代码按照您希望的方式工作：

Private Sub clsValue_test()
Dim Coll As New Collection
Dim myArr()
Dim v As Variant
myArr = Array("String1", "String2", "String3")
For Each v In myArr
    Coll.Add New clsValue, v
    Coll(v) = "NULL"
Next v
Coll("String1") = "myString"    ' it works!
For Each v In myArr
    Debug.Print v, ": "; Coll(v)
Next v
End Sub

生成结果：

String1       : myString
String2       : NULL
String3       : NULL

制作按键删除集合项的函数的一种变体是将其实现为 VBA 属性

Public Property Let CollectionValue(coll As Collection, key As String, value As String)
    On Error Resume Next
    coll.Remove key
    On Error GoTo 0
    coll.Add value, key
End Property


Public Property Get CollectionValue(coll As Collection, key As String) As String
    CollectionValue = coll(key)
End Property

并像这样使用

'Writing
CollectionValue(coll, "Date") = Now()

'Reading
Debug.Print(CollectionValue(coll, "Date")) 

通过忽略 key 是否不存在，它也可以用于添加项目

Sub tcoll()
 Dim c As New Collection
 c.Add Array("1", 2, False)
 c.Add Array("2", 3, False)
 c.Add Array("1", 4, False)
 For Each ci In c:  Debug.Print ci(0), ci(1), ci(2): Next
 If 1 Then
  'ok
  For X = c.Count To 1 Step -1
   Select Case c(X)(0)
   Case "1"
    c.Add Array(c(X)(0), c(X)(1), 1), after:=X
    c.Remove X
   Case "2"
    c.Remove X
   End Select
  Next
 Else
  'Subscript out of range
  For X = 1 To c.Count
   Select Case c(X)(0)
   Case "1"
    c(X)(2) = 1 'no error but collection is not changed
   Case "2"
    c.Remove X
   End Select
  Next
 End If
 For Each ci In c:  Debug.Print ci(0), ci(1), ci(2): Next
 Set c = Nothing
End Sub