使用Excel中的VBA將項目添加到詞典中的特定位置

Question

我需要在字典中的特定鍵和項目對之后添加項目。 本質上，添加成員在集合中允許的行為相同：（ Collection.Add (item [,key] [,before] [,after])

Answer 1

沒有允許使用此功能的Dictionary對象的內置方法。 這是滾動自己的快速方法。 這將完全滿足您的要求，但修改起來應該很簡單：

Function DictAdd(StartingDict As Dictionary, Key, Item, AfterKey) As Dictionary
Dim DictKey As Variant

    Set DictAdd = New Dictionary
    For Each DictKey In StartingDict
        DictAdd.Add DictKey, StartingDict(DictKey)
        If DictKey = AfterKey Then DictAdd.Add Key, Item
    Next DictKey
End Function

要測試它，請運行以下過程：

Sub TestDictAdd()
Dim MyDict As New Dictionary, DictKey As Variant

    MyDict.Add "A", "Alpha"
    MyDict.Add "C", "Charlie"

    Set MyDict = DictAdd(MyDict, "B", "Bravo", "A")
    For Each DictKey In MyDict
        Debug.Print DictKey, MyDict(DictKey)
    Next DictKey
End Sub

這只是為了讓您入門。 如果我自己這樣做，則可能會創建自己的自定義類以使用並創建自定義的Add方法，而不是使用函數。 我還將進行以下改進：

• 添加錯誤處理
• 將AfterKey設為可選參數
• 添加BeforeKey作為可選參數

Answer 2

像這樣？

Option Explicit

Sub Sample()
    Dim Dict As Dictionary
    Dim itm As Variant

    Set Dict = New Dictionary

    Dict.Add "MyKey1", "Hello"
    Dict.Add "MyKey2", "This"
    Dict.Add "MyKey3", "is"
    Dict.Add "MyKey4", "Example"

    '~~> USAGE: Dictionaty Object, Key, Text, Position        
    Additem Dict, "MyKey5", "An", 3

    For Each itm In Dict
        Debug.Print itm & " - " & Dict(itm)
    Next
End Sub

Function Additem(ByRef D As Dictionary, ky As Variant, itm As Variant, pos As Long)
    Dim kyAr() As Variant, itmAr() As Variant
    Dim temp1() As Variant, temp2() As Variant
    Dim i As Long

    kyAr = D.Keys: itmAr = D.Items

    ReDim temp1(UBound(kyAr) + 1)
    ReDim temp2(UBound(itmAr) + 1)

    For i = 0 To pos - 1
        temp1(i) = kyAr(i): temp2(i) = itmAr(i)
    Next

    temp1(pos) = ky: temp2(pos) = itm

    For i = pos + 1 To UBound(temp1)
        temp1(i) = kyAr(i - 1): temp2(i) = itmAr(i - 1)
    Next

    ReDim kyAr(0): ReDim itmAr(0)

    kyAr() = temp1(): itmAr() = temp2()

    D.RemoveAll

    For i = LBound(kyAr) To UBound(kyAr)
        D.Add kyAr(i), itmAr(i)
    Next i
End Function

OUTPUT

之前

MyKey1 - Hello
MyKey2 - This
MyKey3 - is
MyKey4 - Example

后

MyKey1 - Hello
MyKey2 - This
MyKey3 - is
MyKey5 - An
MyKey4 - Example

Answer 3

我沒有對包含所有項目的字典進行排序，而是實現了一個稱為DctAdd的小程序，該過程使添加項時立即對鍵進行排序。 假設鍵為vAdd，項為vItem，類型為variant且要排序的字典均為dct。 所以代替：

dct.Add vAdd, vItem

我用：

DctAdd dct, vItem, vAdd, dam_sortasc 

對於性能，我只包含一些基本測試，因為我發現在項目中使用它時就足夠了。

要使用DctAdd，必須將以下內容復制到相關模塊的聲明部分：

' Just for the performance time measurement -----------------------------
Private Declare Function GetTime Lib "winmm.dll" Alias "timeGetTime" () As Long
' For the execution mode of DctAdd --------------------------------------
' (may be extended to also cover insert before and after)
Public Enum enAddInsertMode
    dam_sortasc = 1
    dam_sortdesc = 2
End Enum

可以將以下代碼復制到任何標准或類模塊中：請注意，在插入之前/之后尚未實現，但添加時間不會很長。

Public Sub DctAdd(ByRef dct As Scripting.Dictionary, _
                  ByVal vItem As Variant, _
                  ByVal vAdd As Variant, _
                  ByVal lMode As enAddInsertMode)
' ----------------------------------------------------------------------
' Add to the Dictionary dct the item vItem with vAdd as the key,
' sorted in ascending or descending order.
'
' If the vAdd key already exists, adding it will be skipped without
' an error. A not existing dictionary is established with the first add
'
' W. Rauschenberger, warbe@cogip.de, Berlin, Feb 2015
' ----------------------------------------------------------------------
Dim i           As Long
Dim dctTemp     As Scripting.Dictionary
Dim vTempKey    As Variant
Dim bAdd        As Boolean

    If dct Is Nothing Then Set dct = New Dictionary

    With dct
        If .count = 0 Then
            .Add vAdd, vItem
            Exit Sub
        Else
            ' -----------------------------------------------------------
            ' The can maybee added directly after the last key
            ' -----------------------------------------------------------
            vTempKey = .Keys()(.count - 1)      ' Get the very last key
            Select Case lMode
                Case dam_sortasc
                    If vAdd > vTempKey Then
                        .Add vAdd, vItem
                        Exit Sub                ' Done!
                    End If
                Case dam_sortdesc
                    If vAdd < vTempKey Then
                        .Add vAdd, vItem
                        Exit Sub                ' Done!
                    End If
            End Select
        End If
    End With

    ' -----------------------------------------------------------------
    ' Since the new key could not simply be added to the dct it must be
    ' added/inserted somewhere in between or before the very first key
    ' ------------------------------------------------------------------
    Set dctTemp = New Dictionary
    bAdd = True
    For Each vTempKey In dct
        With dctTemp
            If bAdd Then ' When the new item has yet not been added
                Select Case lMode
                    Case dam_sortasc
                        If vTempKey > vAdd Then
                            If Not dct.Exists(vAdd) Then
                               .Add vAdd, vItem
                            End If
                            bAdd = False ' Add done
                        End If
                    Case dam_sortdesc
                        If vTempKey < vAdd Then
                            If Not dct.Exists(vAdd) Then
                                .Add vAdd, vItem
                            End If
                            bAdd = False ' Add done
                        End If
                End Select
            End If
            .Add vTempKey, dct.Item(vTempKey)
        End With
    Next vTempKey
                               ' ------------------------------------
    Set dct = dctTemp          ' Return the temporary dictionary with
    Set dctTemp = Nothing      ' the added new item
    Exit Sub                   ' ------------------------------------

on_error:
   Debug.Print "Error in 'DctAdd'!"
End Sub

這是我用於測試的：

Public Sub Testdct1Add()
Dim dct1    As Scripting.Dictionary
Dim dct2    As Scripting.Dictionary
Dim i       As Long
Dim lStart  As Long
Dim lAdd    As Long
Dim vKey    As Variant


    ' -----------------------------------------------------------------------
    Debug.Print vbLf & "DctAdd: Test ascending order"
    ' Add sorted ascending with the key provided in the reverse order
    Set dct1 = Nothing
    For i = 10 To 1 Step -1
        DctAdd dct1, i, i, dam_sortasc
    Next i
    ' Show the result and wait ----------------
    For Each vKey In dct1
        Debug.Print vKey & " " & dct1.Item(vKey)
    Next vKey
    Stop

    ' ------------------------------------------------------------------
    Debug.Print vbLf & "DctAdd: Test descending order"
    ' Add sorted ascending with the key provided in the reverse order
    Set dct1 = Nothing
    For i = 1 To 10
        DctAdd dct1, i, i, dam_sortdesc
    Next i
    ' Show the result and wait ----------------
    For Each vKey In dct1
        Debug.Print vKey & " " & dct1.Item(vKey)
    Next vKey
    Stop

    ' ------------------------------------------------------------------
    lAdd = 500
    Debug.Print vbLf & "DctAdd: Test a best case scenario by adding " & _
                vbLf & lAdd & " items in the desired sort order"
    Set dct1 = Nothing
    lStart = GetTime
    For i = 1 To lAdd
        DctAdd dct1, i, i, dam_sortasc
    Next i
    Debug.Print "Adding " & dct1.count & " items in the target " & _
         vbLf & "sort order = " & GetTime - lStart & " ms"
    Stop

    ' ------------------------------------------------------------------
    lAdd = 500
    Debug.Print vbLf & "DctAdd: Worst case scenarion test by adding " & _
                vbLf & lAdd & " items in the reverse sort order"
    Set dct1 = Nothing
    lStart = GetTime
    For i = lAdd To 1 Step -1
        DctAdd dct1, i, i, dam_sortasc
    Next i
    Debug.Print "Adding " & dct1.count & " items, 4 out of " & vbLf & _ 
                "order = " & GetTime - lStart & " ms"
    Stop

    ' -----------------------------------------------------------------
    lAdd = 1000
    Debug.Print vbLf & "DctAdd: Worst case scenarion test by adding " & _
                vbLf & lAdd & " items in the reverse sort order"
    Set dct1 = Nothing
    lStart = GetTime
    For i = lAdd To 1 Step -1
        DctAdd dct1, i, i, dam_sortasc
    Next i
    Debug.Print "Adding " & dct1.count & " items:" & vbLf & _
                GetTime - lStart & " ms"

    Stop

    ' -----------------------------------------------------------------
    ' Example for using dctAdd to sort any dictionary. The item if dct2 
    ' are temporarily added sorted ascending to the dct1 and finally set 
    ' to dct2
    ' ------------------------------------------------------------------
    Debug.Print vbLf & "DctAdd: Used to sort another Dictionary (dct2)"
    Set dct2 = New Dictionary
    dct2.Add "F", 1
    dct2.Add "A", 2
    dct2.Add "C", 3
    dct2.Add "H", 4
    dct2.Add "D", 5
    dct2.Add "E", 6
    dct2.Add "G", 7
    dct2.Add "B", 8

    Set dct1 = Nothing
    For Each vKey In dct2
        DctAdd dct1, dct2(vKey), vKey, dam_sortasc
    Next vKey
    Set dct2 = dct1
    ' Show the result and wait ----------------
    For Each vKey In dct2
        Debug.Print "Key=" & vKey & ", Item=" & dct2.Item(vKey)
    Next vKey

End Sub