dictionary.exists(key) 添加键

Question

我对 vba 字典很着迷，因为 Exists() 方法没有意义。

我虽然你可以使用 dict.Exists(key) 方法来检查一个键是否在字典中，而不需要进一步的操作。问题是在检查时，键会自动添加到字典中。真的没有意义！

这是我的代码。难道我做错了什么？

Function getContracts(wb As Workbook) As Dictionary
   Dim cData As Variant, fromTo(1 To 2) As Variant
   Dim contracts As New Dictionary, ctrDates As New Collection
   Dim positions As New Dictionary, p As Long, r As Long
   Dim dataSh As String, i As Long
   
   dataSh = "Export"
   
   cData = wb.Worksheets(dataSh).UsedRange
   
   For i = LBound(cData) To UBound(cData)
      fromTo(1) = cData(i, 1)
      fromTo(2) = cData(i, 2)
      Set ctrDates = Nothing
      If IsDate(fromTo(1)) And IsDate(fromTo(2)) Then
         If Not contracts.Exists(cData(i, 3)) Then ' Here it detects correctly that the key doesn't exist
            ctrDates.Add fromTo 
            contracts.Add cData(i, 3), ctrDates ' And here it fails because the key just got added by .Exists()
         Else
            Set ctrDates = contracts(cData(i, 3))
            ctrDates.Add fromTo
            contracts(cData(i, 3)) = ctrDates
         End If
      Else
         Debug.Print "Not a valid date in line " & i
      End If
      
   Next i
   
End Function

Answer 1

您可以将代码缩短为

   For i = LBound(cData) To UBound(cData)
      fromTo(1) = cData(i, 1)
      fromTo(2) = cData(i, 2)
      Set ctrDates = Nothing
      If IsDate(fromTo(1)) And IsDate(fromTo(2)) Then
            If Not IsEmpty(contracts(cData(i, 3))) Then Set ctrDates = contracts(cData(i, 3))
            ctrDates.Add fromTo
            Set contracts(cData(i, 3)) = ctrDates

      Else
         Debug.Print "Not a valid date in line " & i
      End If
      
   Next i

如果更改某个键的值，如果该键不存在，它将自动添加该键。

进一步阅读dictionaries

附言：这也可能会规避 cmets 中描述的奇怪行为，因为您不使用 exist 方法。但另一方面，我在使用字典时从未经历过如此奇怪的行为

Answer 2

字典中日期对的集合

• 需要对Microsoft Scripting Runtime 库的引用才能使其正常工作。

Option Explicit

Sub GetContractsTEST()

    Const dName As String = "Export"

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)

    Dim Contracts As Scripting.Dictionary: Set Contracts = GetContracts(dws)
    If Contracts Is Nothing Then Exit Sub

    Dim Key As Variant, Item As Variant
    For Each Key In Contracts.Keys
        Debug.Print Key
        For Each Item In Contracts(Key)
            Debug.Print Item(1), Item(2)
        Next Item
    Next Key

End Sub

Function GetContracts(ByVal ws As Worksheet) As Scripting.Dictionary
    Const ProcName As String = "GetContracts"
    On Error GoTo ClearError

    Dim cData As Variant: cData = ws.UsedRange.Value
    Dim fromTo(1 To 2) As Variant

    Dim Contracts As New Scripting.Dictionary
    Contracts.CompareMode = TextCompare
    
    Dim r As Long

    For r = LBound(cData) To UBound(cData)
        fromTo(1) = cData(r, 1)
        fromTo(2) = cData(r, 2)
        If IsDate(fromTo(1)) And IsDate(fromTo(2)) Then
            If Not Contracts.Exists(cData(r, 3)) Then
                Set Contracts(cData(r, 3)) = New Collection
            End If
            Contracts(cData(r, 3)).Add fromTo
        Else
            Debug.Print "Not a valid date in line " & r
        End If
    Next r

    Set GetContracts = Contracts

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

Answer 3

可能的解决方案：

我有同样的问题，当没有设置比较更多时往往会发生这种情况。我没有深入研究这个问题，因为这个问题不能总是被复制，而且.Exists() 和.CompareMode 周围的文档不是那么彻底source.

（正如大家所说，您应该启用Microsoft Scripting Runtime 参考以进行早期绑定）

创建新字典时，将其.CompareMode 设置为vbBinaryCompare，这将设置更严格的比较模式，并且在我的情况下还修复了.Exists() 错误。请注意，您只能在空字典上设置 .CompareMode

Dim NewDictionary As New Scripting.Dictionary
NewDictionary.CompareMode = vbBinaryCompare

If NewDictionary.Exists(key) Then
'do things
End If