This page describes about 14 procedures related to Collection And Dictionary objects.

References And Code Libraries
The Dictionary object is part of the Microsoft Scripting Runtime Library, so your project must reference this library. In VBA, go to the Tools menu, choose References, and scroll to and select "Microsoft Scriping Runtime".  The procedures on this page use the Split, Replace, and Join VBA functions, so you must have Excel 2000 or later. The code will not work in Excel 97 or earlier versions. The code used in the functions on this page require the modArraySupport module, available here as a downloadable bas file, and described on the Functions For VBA Arrays page, and the modQSortInPlace module, available here as a downloadable bas file, and described on the Sorting Arrays With QSort page. You should Import these code modules into your VBA Project.

The procedures described on this page are available in a downloadable bas module file here, or a complete workbook, which includes the ArraySupport and QSort modules, here.

The following procedures are described on this page:

          ArrayToCollection
          ArrayToDictionary
          CollectionToArray
          CollectionToDictionary
          CollectionToRange
          CreateDictionaryKeyFromCollectionItem
          DictionaryToArray
          DictionaryToCollection
          DictionaryToRange
          KeyExistsInCollection
          RangeToCollection
          RangeToDictionary
          SortCollection
          SortDictionary
 

ArrayToCollection

    Public Function ArrayToCollection(Arr As Variant, ByRef Coll As Collection) As Boolean

This procedure takes the value from an array Arr and adds the to the collection Coll.  The existing contents of Coll are preserved. Arr may be either a 1-dimensional or 2-dimensional array. If Arr is a 1-dimensional array, its contents are added to Coll without keys. If Arr is a 2-dimensional array, the first column of the array is assumed to be the Item to added to Coll and the second column of the array is assumed to be the Key value for that item. If the Key value is an empty string, Item is added without a key. If the Key value is not an empty string, the Item is added to Coll with that key value. The code for ArrayToCollection is shown below:

Public Function ArrayToCollection(Arr As Variant, ByRef Coll As Collection) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ArrayToCollection
' This function converts an array to a Collection. Arr may be either a 1-dimensional
' arrary or a two-dimensional array. If Arr is a 1-dimensional array, each element
' of the array is added to Coll without a key. If Arr is a 2-dimensional array,
' the first column is assumed to the be Item to be added, and the second column
' is assumed to be the Key for that item.
' Items are added to the Coll collection. Existing contents are preserved.
' This function returns True if successful, or False if an error occurs.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim Ndx As Long
Dim KeyVal As String

''''''''''''''''''''''''''
' Ensure Arr is an array.
'''''''''''''''''''''''''
If IsArray(Arr) = False Then
    ArrayToCollection = False
    Exit Function
End If

''''''''''''''''''''''''''''''''''''
' Work with either a 1-dimensional
' or 2-dimensional array. Any other
' number of dimensions will cause
' a error. Use On Error to
' trap for errors (most likely a
' duplicate key error).
'''''''''''''''''''''''''''''''''''
On Error GoTo ErrH:
Select Case NumberOfArrayDimensions(Arr:=Arr)
    Case 0
        '''''''''''''''''''''''''''''''
        ' Unallocated array. Exit with
        ' error.
        '''''''''''''''''''''''''''''''
        ArrayToCollection = False
        Exit Function
        
    Case 1
        ''''''''''''''''''''''''''''''
        ' Arr is a single dimensional
        ' array. Load the elements of
        ' the array without keys.
        ''''''''''''''''''''''''''''''
        For Ndx = LBound(Arr) To UBound(Arr)
            Coll.Add Item:=Arr(Ndx)
        Next Ndx
    
    Case 2
        '''''''''''''''''''''''''''''
        ' Arr is a two-dimensional
        ' array. The first column
        ' is the Item and the second
        ' column is the Key.
        '''''''''''''''''''''''''''''
        For Ndx = LBound(Arr, 1) To UBound(Arr, 1)
            KeyVal = Arr(Ndx, 1)
            If Trim(KeyVal) = vbNullString Then
                '''''''''''''''''''''''''''''''''
                ' Key is empty. Add to collection
                ' without a key.
                '''''''''''''''''''''''''''''''''
                Coll.Add Item:=Arr(Ndx, 1)
            Else
                '''''''''''''''''''''''''''''''''
                ' Key is not empty. Add with key.
                '''''''''''''''''''''''''''''''''
                Coll.Add Item:=Arr(Ndx, 0), Key:=KeyVal
            End If
        Next Ndx
    
    Case Else
        '''''''''''''''''''''''''''''
        ' The array has 3 or more
        ' dimensions. Return an
        ' error.
        '''''''''''''''''''''''''''''
        ArrayToCollection = False
        Exit Function

End Select

ArrayToCollection = True
Exit Function

ErrH:
    ''''''''''''''''''''''''''''''''
    ' An error occurred, most likely
    ' a duplicate key error. Return
    ' False.
    ''''''''''''''''''''''''''''''''
    ArrayToCollection = False

End Function

ArrayToDictionary

    Public Function ArrayToDictionary(Arr As Variant, Dict As Scripting.Dictionary) As Boolean

This procedure loads the contents of  a two-dimensional array Arr into a specified Dictionary object Dict. Arr must be a two dimensional array. The first column of the array is the Item to be added to Dict, and the second column of the array is the Key for the Item. This function returns True if successful, or False if an error occurred (most likely a duplicate key error). The existing entries in Dict are preserved. The code for the ArrayToDictionary function is shown below:

Public Function ArrayToDictionary(Arr As Variant, Dict As Scripting.Dictionary) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ArrayToDictionary
' This function loads the contents of a two dimensional array into the Dict dictionary
' object. Arr must be two dimensional. The first column is the Item to add to the Dict
' dictionary, and the second column is the Key value of the Item. The existing items
' in the dictionary are left intact.
' The function returns True if successful, or False if an error occurred.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim Ndx As Long
Dim ItemVar As Variant
Dim KeyVal As String

'''''''''''''''''''''''''
' Ensure Arr is an array.
'''''''''''''''''''''''''
If IsArray(Arr) = False Then
    ArrayToDictionary = False
    Exit Function
End If

'''''''''''''''''''''''''''''''
' Ensure Arr is two dimensional
'''''''''''''''''''''''''''''''
If NumberOfArrayDimensions(Arr:=Arr) <> 2 Then
    ArrayToDictionary = False
    Exit Function
End If
    
'''''''''''''''''''''''''''''''''''
' Loop through the arary and
' add the items to the Dictionary.
'''''''''''''''''''''''''''''''''''
On Error GoTo ErrH:
For Ndx = LBound(Arr, 1) To UBound(Arr, 1)
    Dict.Add Key:=Arr(Ndx, LBound(Arr, 2) + 1), Item:=Arr(Ndx, LBound(Arr, 2))
Next Ndx
    
'''''''''''''''''
' Return Success.
'''''''''''''''''
ArrayToDictionary = True
Exit Function

ErrH:
ArrayToDictionary = False

End Function

CollectionToArray

	Public Function CollectionToArray(Coll As Collection, Arr As Variant) As Boolean

This procedure loads an array with the value of a collection. The Coll Collection may include any type of variables, including objects, other the User Defined Types.  The function erases the existing contents of the Arr variable. Arr must be a dynamic array. The procedure returns True if successful or False if an error occurred. The code for CollectionToArray is shown below:

Public Function CollectionToArray(Coll As Collection, Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CollectionToArray
' This function converts a collection object to a single dimensional array.
' The elements of Collection may be any type of data except User Defined Types.
' The procedure will populate the array Arr with the elements of the collection.
' Only the collection items, not the keys, are stored in Arr. The function returns
' True if the the Collection was successfully converted to an array, or False
' if an error occcurred.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim V As Variant
Dim Ndx As Long

''''''''''''''''''''''''''''''
' Ensure Coll is not Nothing.
''''''''''''''''''''''''''''''
If Coll Is Nothing Then
    CollectionToArray = False
    Exit Function
End If

''''''''''''''''''''''''''''''
' Ensure Arr is an array and
' is dynamic.
''''''''''''''''''''''''''''''
If IsArray(Arr) = False Then
    CollectionToArray = False
    Exit Function
End If
If IsArrayDynamic(Arr:=Arr) = False Then
    CollectionToArray = False
    Exit Function
End If

''''''''''''''''''''''''''''
' Ensure Coll has at least
' one item.
''''''''''''''''''''''''''''
If Coll.Count < 1 Then
    CollectionToArray = False
    Exit Function
End If
    
''''''''''''''''''''''''''''''
' Redim Arr to the number of
' elements in the collection.
'''''''''''''''''''''''''''''
ReDim Arr(1 To Coll.Count)
'''''''''''''''''''''''''''''
' Loop through the colletcion
' and add the elements of
' Collection to Arr.
'''''''''''''''''''''''''''''
For Ndx = 1 To Coll.Count
    If IsObject(Coll(Ndx)) = True Then
        Set Arr(Ndx) = Coll(Ndx)
    Else
        Arr(Ndx) = Coll(Ndx)
    End If
Next Ndx

CollectionToArray = True

End Function

CollectionToDictionary

    Public Function CollectionToDictionary(Coll As Collection, _
        Dict As Scripting.Dictionary) As Boolean

This procedure converts a Collection object Coll to a Dictionary object Dict. Because a Dictionary item must have a unique key, this procedure calls a procedure named CreateDictionaryKeyFromCollectionItem to get the appropriate key to be used in the Dictionary. It is up to you to write the code in the CreateDictionaryKeyFromCollectionItem function to create a unique key.  The existing value so the Dict Dictionary are destroyed and the Dictionary is recreated.

The  CreateDictionaryKeyFromCollectionItem  procedure is declared as follows:

    Private Function CreateDictionaryKeyFromCollectionItem( _ 
        Dict As Scripting.Dictionary, _ 
        Item As Variant) As String

This function must return a unique key value. The Dictionary and the current Item are passed to the  CreateDictionaryKeyFromCollectionItem  function.

The code for CollectionToDictionary  and CreateDictionaryKeyFromCollectionItem is shown below:

Public Function CollectionToDictionary(Coll As Collection, _
    Dict As Scripting.Dictionary) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CollectionToDictionary
'
' This function converts a Collection Objct to a
' Dictionary object. This code requires a reference
' the Microsoft Scripting RunTime Library.
'
' It calls a private procedure named
' CreateDictionaryKeyFromCollectionItem that you supply
' to create a Dictionary Key from an Item in the Collection.
' This must return a String value that will be unique within
' the Dictionary.
'
' If an error occurs (e.g., a Key value returned by
' CreateDictionaryKeyFromCollectionItem already exists
' in the Dictionary object), Dictionary is set to Nothing.
' The function returns True if the conversion from Collection
' to Dictionary was successful, or False if an error occurred.
' If it returns False, the Dictionary is set to Nothing.
'
' The code destroys the existing contents of Dict
' and replaces them with the new elements. The Coll
' Collection is left intact with no changes.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim Ndx As Long
Dim ItemKey As String
Dim ItemVar As Variant

''''''''''''''''''''''''''''''''''''''''''''
' Ensure Coll is not Nothing.
''''''''''''''''''''''''''''''''''''''''''''
If (Coll Is Nothing) Then
    CollectionToDictionary = False
    Exit Function
End If
''''''''''''''''''''''''''''''''''''''''''''
' Reset Dict to a new, empty Dictionary
''''''''''''''''''''''''''''''''''''''''''''
Set Dict = Nothing
Set Dict = New Scripting.Dictionary
'''''''''''''''''''''''''''''''''''''''''''
' Ensure we have at least one element in
' the collection object.
'''''''''''''''''''''''''''''''''''''''''''
If Coll.Count = 0 Then
    Set Dict = Nothing
    CollectionToDictionary = False
    Exit Function
End If
    
'''''''''''''''''''''''''''''''''''''''''''
' Loop through the collection and convert
' each item in the collection to an item
' for the dictionary. Call
' CreateDictionaryKeyFromCollectionItem
' to get the Key to be used in the Dictionary
' item.
'''''''''''''''''''''''''''''''''''''''''''
For Ndx = 1 To Coll.Count
    '''''''''''''''''''''''''''''''''''''''
    ' Coll may contain object variables.
    ' Test for this condition and set
    ' ItemVar appropriately.
    '''''''''''''''''''''''''''''''''''''''
    If IsObject(Coll(Ndx)) = True Then
        Set ItemVar = Coll(Ndx)
    Else
        ItemVar = Coll(Ndx)
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Call the user-supplied CreateDictionaryKeyFromCollectionItem
    ' function to get the Key to be used in the Dictionary.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ItemKey = CreateDictionaryKeyFromCollectionItem(Dict:=Dict, Item:=ItemVar)
    ''''''''''''''''''''''''''''''''
    ' ItemKey must not be spaces or
    ' an empty string.
    ''''''''''''''''''''''''''''''''
    If Trim(ItemKey) = vbNullString Then
        CollectionToDictionary = False
        Exit Function
    End If
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' See if ItemKey already exists in the Dictionary.
    ' If so, return False. You can't have duplicate keys.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Dict.Exists(Key:=ItemKey) = True Then
        Set Dict = Nothing
        CollectionToDictionary = False
        Exit Function
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' ItemKey does not exist in Dict, so add ItemVar to
    ' Dict with a key of ItemKey.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dict.Add Key:=ItemKey, Item:=ItemVar
Next Ndx
CollectionToDictionary = True

End Function

Private Function CreateDictionaryKeyFromCollectionItem( _
    Dict As Scripting.Dictionary, _
    Item As Variant) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CreateDictionaryKeyFromCollectionItem
' This function is called by CollectionToDictionary to create
' a Key for a Dictionary item that is take from a Collection
' item. The collection item is passed in the Item parameter.
' It is up to you to create a unique key based on the
' Item parameter.
' Dict is the Dictionary for which the result of this function
' will be used as a Key, and Item is the item of the
' Dictionary for which this procedure is creating a Key.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ItemKey As String
''''''''''''''''''''''''''''''''''''''''''
' Your code to set ItemKey to the
' appropriate string value. ItemKey
' must not be all spaces or vbNullString.
''''''''''''''''''''''''''''''''''''''''''


CreateDictionaryKeyFromCollectionItem = ItemKey
End Function

CollectionToRange

	Public Function CollectionToRange(Coll As Collection, StartCells As Range) As Boolean

This function populates a range with the items of a Collection. The items of the Collection Coll will be written  to the range, starting with StartCells. If the StartCells range is one cell, the Collection is written to the cells starting with StartCell and moving downwards in the same column. If StartCells references two cells, the Collection is written in the same orientation as StartCells. That is, the two cells of StartCells are in the same row (e.g., A1:B1), the Collection is written across the row, starting in StartCells. If the two cells of StartCells are in the same column (e.g., A1:A2), the Collection is written down the column, starting in StartCells. If StartsCells contains more than two cells, ONLY those cells will be written to. StartCells must be a single-area range. If an item in Collection is an object, it is skipped.

The code for CollectionToRange is shown below:

Public Function CollectionToRange(Coll As Collection, StartCells As Range) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CollectionToRange
' This procedure writes the contents of a Collection Coll to a range of cells starting
' in StartCells. If StartCells is a single cell, the contents of Collection are
' written downward in a single column starting in StartCell. If StartCell is
' two cells, the Collection is written in the same orientation (down a column or
' across a row) as StartCells. If StartCells is more than two cells, ONLY those
' cells will be written to, moving across then down. StartCells must be a single
' area range.
'
' If an item in Coll is an object, it is skipped.
'
' The function returns True if successful or False if an error occurred.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim DestRng As Range
Dim V As Variant
Dim Ndx As Long

'''''''''''''''''''''''''''''''''''''
' Ensure parameters are not Nothing.
'''''''''''''''''''''''''''''''''''''
If (Coll Is Nothing) Or (StartCells Is Nothing) Then
    CollectionToRange = False
    Exit Function
End If

'''''''''''''''''''''''''''''''''''''
' Ensure StartCells is a single area.
'''''''''''''''''''''''''''''''''''''
If StartCells.Areas.Count > 1 Then
    CollectionToRange = False
    Exit Function
End If

If StartCells.Cells.Count = 1 Then
    '''''''''''''''''''''''''''''''''''''
    ' StartCells is one cell. Write out
    ' the collection moving downwards.
    '''''''''''''''''''''''''''''''''''''
    Set DestRng = StartCells
    For Each V In Coll
        If IsObject(V) = False Then
            DestRng.Value = V
            If DestRng.Row < DestRng.Parent.Rows.Count Then
                Set DestRng = DestRng(2, 1)
            Else
                CollectionToRange = False
                Exit Function
            End If
                
        End If
    Next V
    CollectionToRange = True
    Exit Function
End If

If StartCells.Cells.Count = 2 Then
    ''''''''''''''''''''''''''''''''''
    ' Test the orientation of the two
    ' cells in StartCells.
    ''''''''''''''''''''''''''''''''''
    If StartCells.Rows.Count = 1 Then
        '''''''''''''''''''''''''''''''''
        ' Write out the Colleciton moving
        ' across the row.
        '''''''''''''''''''''''''''''''''
        Set DestRng = StartCells.Cells(1, 1)
        For Each V In Coll
            If IsObject(V) = False Then
                DestRng.Value = V
                If DestRng.Column < StartCells.Parent.Columns.Count Then
                    Set DestRng = DestRng(1, 2)
                Else
                    CollectionToRange = False
                    Exit Function
                End If
            End If
        Next V
        CollectionToRange = True
        Exit Function
    Else
        '''''''''''''''''''''''''''''''''
        ' Write out the Colleciton moving
        ' down the column.
        '''''''''''''''''''''''''''''''''
        Set DestRng = StartCells.Cells(1, 1)
        For Each V In Coll
            If IsObject(V) = False Then
                DestRng.Value = V
                If DestRng.Row < StartCells.Parent.Rows.Count Then
                    Set DestRng = DestRng(2, 1)
                Else
                    CollectionToRange = False
                    Exit Function
                End If
            End If
        Next V
        CollectionToRange = True
        Exit Function
    End If
End If
'''''''''''''''''''''''''''''''''''''
' Write the collection only into
' Cells of StartCells.
'''''''''''''''''''''''''''''''''''''
For Ndx = 1 To StartCells.Cells.Count
    If Ndx <= Coll.Count Then
        V = Coll(Ndx)
        If IsObject(V) = False Then
            StartCells.Cells(Ndx).Value = V
        End If
    End If
Next Ndx

CollectionToRange = True


End Function

DictionaryToArray

    Public Function DictionaryToArray(Dict As Scripting.Dictionary, Arr As Variant) As Boolean

This procedure populates the array Arr with the items and keys for the Dict Dictionary. Arr must be declared as an array of variants, e.g.,

    Dim Arr() As Variant

    ReDim Arr(0 To Dict.Count - 1, 0 To 1)

The original contents of Arr are destroyed. The code for DictionaryToArray is shown below:

Public Function DictionaryToArray(Dict As Scripting.Dictionary, Arr As Variant) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DictionaryToArray
' This creates a 0-based, 2-dimensional array Arr from a Dictionary object. Each
' row of the array is one element of the Dictionary. The first column of the array is the
' Key of the dictionary item, and the second column is the Key of the item in the
' dictionary. Arr MUST be an dynamic array of Variants, e.g.,
' Dim Arr() As Variant
' The VarType of Arr is tested, and if it does not equal 8204 (vbArray + vbVariant) an
' error occurs.
'
' The existing content of Arr is destroyed. The function returns True if successsful
' or False if an error occurred.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Long

'''''''''''''''''''''''''''''
' Ensure that Arr is an array
' of Variants.
'''''''''''''''''''''''''''''
If VarType(Arr) <> (vbArray + vbVariant) Then
    DictionaryToArray = False
    Exit Function
End If

''''''''''''''''''''''''''''''''
' Ensure Arr is a dynamic array.
''''''''''''''''''''''''''''''''
If IsArrayDynamic(Arr:=Arr) = False Then
    DictionaryToArray = False
    Exit Function
End If
   
'''''''''''''''''''''''''''''
' Ensure Dict is not nothing.
'''''''''''''''''''''''''''''
If Dict Is Nothing Then
    DictionaryToArray = False
    Exit Function
End If
    
'''''''''''''''''''''''''''
' Ensure that Dict contains
' at least one entry.
'''''''''''''''''''''''''''
If Dict.Count = 0 Then
    DictionaryToArray = False
    Exit Function
End If

'''''''''''''''''''''''''''''
' Redim the Arr variable.
'''''''''''''''''''''''''''''
ReDim Arr(0 To Dict.Count - 1, 0 To 1)

For Ndx = 0 To Dict.Count - 1
    Arr(Ndx, 0) = Dict.Keys(Ndx)
    '''''''''''''''''''''''''''''''''''''''''
    ' Test to see if the item in the Dict is
    ' an object. If so, use Set.
    '''''''''''''''''''''''''''''''''''''''''
    If IsObject(Dict.Items(Ndx)) = True Then
        Set Arr(Ndx, 1) = Dict.Items(Ndx)
    Else
        Arr(Ndx, 1) = Dict.Items(Ndx)
    End If

Next Ndx

'''''''''''''''''
' Return success.
'''''''''''''''''
DictionaryToArray = True

End Function

DictionaryToCollection

    Public Function DictionaryToCollection(Dict As Scripting.Dictionary, Coll As Collection, _
        Optional PreserveColl As Boolean = False, _
        Optional StopOnDuplicateKey As Boolean = False) As Boolean

This procedure converts a Dictionary object Dict to a Collection object Coll.  This procedure converts an existing Dictionary to a new Collection object. Keys from the Dictionary are used as the keys for the Collection. This function returns True if successful, or False if an error occurred. The contents of Dict are not modified.  If PreserveColl is omitted or False, the existing contents of the Coll collection are destroyed. If PreserveColl is True, the existing contents of Coll are preserved. If PreserveColl is true, then the possibility exists that we will run into duplicate key values for the Collection. If StopOnDuplicateKey is omitted or false, this error is ignored, but the item from the Dict Dictionary will not be added to Coll Collection. If StopOnDuplicateKey is True, the procedure will terminate, and not all of the items in the Dict Dictionary will have copied to the Coll Collection. The Coll Collection will be in an indeterminant state. The code for the DictionaryToCollection is shown below:

Public Function DictionaryToCollection(Dict As Scripting.Dictionary, Coll As Collection, _
    Optional PreserveColl As Boolean = False, _
    Optional StopOnDuplicateKey As Boolean = False) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DictionaryToCollection
' This procedure converts an existing Dictionary to a new Collection object. Keys from
' the Dictionary are used as the keys for the Collection. This function returns True
' if successful, or False if an error occurred. The contents of Dict are not modified.
' If PreserveColl is omitted or False, the existing contents of the Coll collection are
' destroyed. If PreserveColl is True, the existing contents of Coll are preserved.
' If PreserveColl is true, then the possibility exists that we will run into duplicate
' key values for the Collection. If StopOnDuplicateKey is omitted or false, this error
' is ignored, but the item from the Dict Dictionary will not be added to Coll Collection.
' If StopOnDuplicateKey is True, the procedure will terminate, and not all of the items in
' the Dict Dictionary will have copied to the Coll Collection. The Coll Collection will
' be in an indeterminant state.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Long
Dim ItemVar As Variant
Dim KeyVal As String

''''''''''''''''''''''''''''''''
' Ensure Dict is not Nothing
''''''''''''''''''''''''''''''''
If Dict Is Nothing Then
    DictionaryToCollection = False
    Exit Function
End If

'''''''''''''''''''''''''''''''''
' If PreseveColl is omitted or
' False, destroy the existing
' Coll Collection.
'''''''''''''''''''''''''''''''''
If PreserveColl = False Then
    Set Coll = Nothing
    Set Coll = New Collection
End If

'''''''''''''''''''''''''''''''''
' Loop through the Dictionary
' and transfer the data to
' the Collection.
'''''''''''''''''''''''''''''''''
On Error Resume Next
For Ndx = 0 To Dict.Count - 1
    If IsObject(Dict.Items(Ndx)) = True Then
        Set ItemVar = Dict.Items(Ndx)
    Else
        ItemVar = Dict.Items(Ndx)
    End If
    KeyVal = Dict.Keys(Ndx)
    Err.Clear
    Coll.Add Item:=ItemVar, Key:=KeyVal
    If Err.Number <> 0 Then
        If StopOnDuplicateKey = True Then
            DictionaryToCollection = False
            Exit Function
        End If
    End If
Next Ndx
DictionaryToCollection = True
End Function

DictionaryToRange

	Public Function DictionaryToRange(Dict As Scripting.Dictionary, StartCells As Range) As Boolean

This function populates a range with the items of a Dictionary. The items of the Dictionary Dict will be written  to the range, starting with StartCells. If the StartCells range is one cell, the Dictionary is written to the cells starting with StartCell and moving downwards in the same column. If StartCells references two cells, the Dictionary is written in the same orientation as StartCells. That is, the two cells of StartCells are in the same row (e.g., A1:B1), the Dictionary is written across the row, starting in StartCells. If the two cells of StartCells are in the same column (e.g., A1:A2), the Dictionary is written down the column, starting in StartCells. If StartsCells contains more than two cells, ONLY those cells will be written to. StartCells must be a single-area range. If an item in Collection is an object, it is skipped.

The code for DictionaryToRange is shown below:

Public Function DictionaryToRange(Dict As Scripting.Dictionary, StartCells As Range) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DictionaryToRange
' This procedure writes the contents of a Dictionary Dict to a range of cells starting
' in StartCells. If StartCells is a single cell, the contents of Dict are
' written downward in a single column starting in StartCell. If StartCell is
' two cells, the Dictionary is written in the same orientation (down a column or
' across a row) as StartCells. If StartCells is more than two cells, ONLY those
' cells will be written to, moving across then down. StartCells must be a single
' area range.
'
' If an item in Dict is an object, it is skipped.
'
' The function returns True if successful or False if an error occurred.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim DestRng As Range
Dim V As Variant
Dim Ndx As Long

'''''''''''''''''''''''''''''''''''''
' Ensure parameters are not Nothing.
'''''''''''''''''''''''''''''''''''''
If (Dict Is Nothing) Or (StartCells Is Nothing) Then
    DictionaryToRange = False
    Exit Function
End If

'''''''''''''''''''''''''''''''''''''
' Ensure StartCells is a single area.
'''''''''''''''''''''''''''''''''''''
If StartCells.Areas.Count > 1 Then
    DictionaryToRange = False
    Exit Function
End If

If StartCells.Cells.Count = 1 Then
    '''''''''''''''''''''''''''''''''''''
    ' StartCells is one cell. Write out
    ' the collection moving downwards.
    '''''''''''''''''''''''''''''''''''''
    Set DestRng = StartCells
    For Each V In Dict.Items
        If IsObject(V) = False Then
            DestRng.Value = V
            If DestRng.Row < DestRng.Parent.Rows.Count Then
                Set DestRng = DestRng(2, 1)
            Else
                DictionaryToRange = False
                Exit Function
            End If
                
        End If
    Next V
    DictionaryToRange = True
    Exit Function
End If

If StartCells.Cells.Count = 2 Then
    ''''''''''''''''''''''''''''''''''
    ' Test the orientation of the two
    ' cells in StartCells.
    ''''''''''''''''''''''''''''''''''
    If StartCells.Rows.Count = 1 Then
        '''''''''''''''''''''''''''''''''
        ' Write out the Colleciton moving
        ' across the row.
        '''''''''''''''''''''''''''''''''
        Set DestRng = StartCells.Cells(1, 1)
        For Each V In Dict.Items
            If IsObject(V) = False Then
                DestRng.Value = V
                If DestRng.Column < StartCells.Parent.Columns.Count Then
                    Set DestRng = DestRng(1, 2)
                Else
                    DictionaryToRange = False
                    Exit Function
                End If
            End If
        Next V
        DictionaryToRange = True
        Exit Function
    Else
        '''''''''''''''''''''''''''''''''
        ' Write out the Dictionary moving
        ' down the column.
        '''''''''''''''''''''''''''''''''
        Set DestRng = StartCells.Cells(1, 1)
        For Each V In Dict.Items
            If IsObject(V) = False Then
                DestRng.Value = V
                If DestRng.Row < StartCells.Parent.Rows.Count Then
                    Set DestRng = DestRng(2, 1)
                Else
                    DictionaryToRange = False
                    Exit Function
                End If
            End If
        Next V
        DictionaryToRange = True
        Exit Function
    End If
End If
'''''''''''''''''''''''''''''''''''''
' Write the Dictionary only into
' Cells of StartCells.
'''''''''''''''''''''''''''''''''''''
For Ndx = 1 To StartCells.Cells.Count
    If Ndx <= Dict.Count Then
        V = Dict.Items(Ndx - 1)
        If IsObject(V) = False Then
            StartCells.Cells(Ndx).Value = V
        End If
    End If
Next Ndx

DictionaryToRange = True


End Function

KeyExistsInCollection

    Public Function KeyExistsInCollection(Coll As Collection, KeyName As String) As Boolean

This procedure returns True if KeyName exists in the Collection Coll, or False if KeyName does not exist in Coll. The code for KeyExistsInColllection is shown below:

Public Function KeyExistsInCollection(Coll As Collection, KeyName As String) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' KeyExistsInCollection
' This function returns True if KeyName exists the Coll Collection,
' or False if KeyName does not exist.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim V As Variant
    On Error Resume Next
    Err.Clear
    V = Coll(KeyName)
    If Err.Number = 0 Then
        KeyExistsInCollection = True
    Else
        KeyExistsInCollection = False
    End If
End Function

RangeToCollection

    Function RangeToCollection(KeyRange As Range, ItemRange As Range, Coll As Collection, _
        Optional RangeAsObject As Boolean = False, _
        Optional StopOnDuplicateKey As Boolean = True, _
        Optional ReplaceOnDuplicateKey As Boolean = False) As Boolean

This procedure loads a Collection object with Items and optionally Keys from a range on a worksheet. KeyRange is a Range of cells containing the Key values. This parameter may be Nothing. If KeyRange is Nothing, items are added to the collection without keys.  ItemRange is a Range of cells containing the items to add to the collection.  ItemRange may NOT be Nothing. If both KeyRange and ItemRange are not Nothing, then they must be the same size and each must comprise only one Area. Coll is the Collection object to which the items are to be added. If Coll is Nothing, a new Collection is created. The RangeAsObject parameter indicates whether range object or the Text of a cell is to be added to the Collection. If RangeAsObject is omitted or False, the Text of each cell in ItemRange is added to the Collection. If RangeAsObject is True, Range Objects, not the values in the ranges, are added to the Collection.

StopOnDuplicateKey and ReplaceOnDuplicateKey determine what action is to be taken if a duplicate key is encountered. If StopOnDuplicateKey is omitted or True, the function terminates when a duplicate key is encountered and the function returns False.  Items added to the Collection prior to the duplicate key condition will remain in the Collection. ReplaceOnDuplicateKey is ignored if StopOnDuplicateKey is omitted or True. If StopOnDuplicateKey is False, then if ReplaceOnDuplicateKey is True, then the existing item with the given key is removed from the Collection and replaced with the new item. If ReplaceOnDuplicateKey is False or omitted, the function will continue processing, but the item which caused the duplicate key condition will not be added to the Collection.

The function returns True if successful, or False if an error occurred. The procedure is shown below. This function requires the KeyExistsInCollection function, described above.

Function RangeToCollection(KeyRange As Range, ItemRange As Range, Coll As Collection, _
    Optional RangeAsObject As Boolean = False, _
    Optional StopOnDuplicateKey As Boolean = True, _
    Optional ReplaceOnDuplicateKey As Boolean = False) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RangeToCollection
' This function load an existing Collection Coll with items from worksheet
' ranges.
'
' The KeyRange and ItemRange must be the same size. Each element in KeyRange
' is the Key value for the corresponding item in ItemRange.
'
' KeyRange may be Nothing. In this case, the items in ItemRange are added to
' the Collection Coll without keys.
'
' If RangeAsObject is omitted of False, the Items added to the Collection are
' the values in the cells of ItemRange. If RangeAsObject is True, the cells
' are added as objects to the Collection.
'
' If a duplicate key is encountered when adding an item to Coll, the code
' will do one of the following:
'   If StopOnDuplicateKey is omitted or True, the funcion stops processing
'   and returns False. Items added to the Collection before the duplicate key
'   was encountered remain in the Collection.
'
'   If StopOnDuplicateKey is False, then if ReplaceOnDuplicateKey is False,
'   the Item that caused the duplicate key error is not added to the Collection
'   but processing continues with the rest of the items in the range. If
'   ReplaceOnDuplicateKey if True, the existing item in the Collection is
'   deleted and replaced with the new item.
'
' If Coll is Nothing, it will be created as a new Collection.
'
' The function returns True if all items were added to the Collection, or False
' if an error occurred.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim IRng As Range
Dim KeyExists As Boolean
Dim KeyNdx As Long

'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Ensure the KeyRange and ItemRange variables are not
' Nothing.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If (ItemRange Is Nothing) Then
    RangeToCollection = False
    Exit Function
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Ensure KeyRange and ItemRange as the same size.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Not KeyRange Is Nothing Then
    If (KeyRange.Rows.Count <> ItemRange.Rows.Count) Or _
        (KeyRange.Columns.Count <> ItemRange.Columns.Count) Then
        RangeToCollection = False
        Exit Function
    End If
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Ensure both KeyRange and ItemRange are single area
' ranges.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If ItemRange.Areas.Count > 1 Then
    RangeToCollection = False
    Exit Function
End If

If Not KeyRange Is Nothing Then
    If KeyRange.Areas.Count > 1 Then
        RangeToCollection = False
        Exit Function
    End If
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If Coll is Nothing, create a new Collection.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Coll Is Nothing Then
    Set Coll = New Collection
End If

''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Loop through ItemRange, testing whether the Key exists
' and adding items to the Collection.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For Each IRng In ItemRange.Cells
    KeyNdx = KeyNdx + 1
    If KeyRange Is Nothing Then
        KeyExists = False
    Else
        KeyExists = KeyExistsInCollection(Coll:=Coll, KeyName:=KeyRange.Cells(KeyNdx))
    End If
    
    If KeyExists = True Then
        '''''''''''''''''''''''''''''''''''''''''''
        ' The key already exists in the Collection.
        ' Determine what to do.
        '''''''''''''''''''''''''''''''''''''''''''
        If StopOnDuplicateKey = True Then
            RangeToCollection = False
            Exit Function
        Else
            ''''''''''''''''''''''''''''''''''''''
            ' Do nothing here. Test the value of
            ' ReplaceOnDuplicateKey below.
            ''''''''''''''''''''''''''''''''''''''
        End If
        '''''''''''''''''''''''''''''''''''''''''
        ' If ReplaceOnDuplicateKey is True then
        ' remove the existing entry. Otherwise,
        ' exit the function.
        '''''''''''''''''''''''''''''''''''''''''
        If ReplaceOnDuplicateKey = True Then
            Coll.Remove KeyRange.Cells(KeyNdx)
            KeyExists = False
        Else
            If StopOnDuplicateKey = True Then
                RangeToCollection = False
                Exit Function
            End If
        End If
    End If
    If KeyExists = False Then
        '''''''''''''''''''''''''''''''
        ' Check KeyRange  to see if
        ' we're adding with Keys.
        '''''''''''''''''''''''''''''''
        If Not KeyRange Is Nothing Then
            '''''''''''''''''''''''''
            ' Add with key.
            '''''''''''''''''''''''''
            If RangeAsObject = True Then
                Coll.Add Item:=IRng, Key:=KeyRange.Cells(KeyNdx)
            Else
                Coll.Add Item:=IRng.Text, Key:=KeyRange.Cells(KeyNdx)
            End If
        Else
            '''''''''''''''''''''
            ' Add without key.
            If RangeAsObject = True Then
                Coll.Add Item:=IRng
            Else
                Coll.Add Item:=IRng.Text
            End If
            '''''''''''''''''''''
            
        End If
    End If
Next IRng

'''''''''''''''''
' Return Success.
'''''''''''''''''
RangeToCollection = True

End Function

RangeToDictionary

    Function RangeToDictionary(KeyRange As Range, ItemRange As Range, Dict As Scripting.Dictionary, _
        Optional RangeAsObject As Boolean = False, _
        Optional StopOnDuplicateKey As Boolean = True, _
        Optional ReplaceOnDuplicateKey As Boolean = False) As Boolean

This procedure loads a Dictionary object with Items and Keys from a range on a worksheet. KeyRange is a Range of cells containing the Key values. ItemRange is a Range of cells containing the items to add to the collection.  Both KeyRange and ItemRange must not be Nothing, and they must be the same size and each must comprise only one Area. Dictis the Dictionary object to which the items are to be added. If Dict is Nothing, a new Dictionary is created. The RangeAsObject parameter indicates whether range object or the Text of a cell is to be added to the Dictionary. If RangeAsObject is omitted or False, the Text of each cell in ItemRange is added to the Dictionary. If RangeAsObject is True, Range Objects, not the values in the ranges, are added to the Dictionary.

StopOnDuplicateKey and ReplaceOnDuplicateKey determine what action is to be taken if a duplicate key is encountered. If StopOnDuplicateKey is omitted or True, the function terminates when a duplicate key is encountered and the function returns False.  Items added to the Dictionary prior to the duplicate key condition will remain in the Dictionary. ReplaceOnDuplicateKey is ignored if StopOnDuplicateKey is omitted or True. If StopOnDuplicateKey is False, then if ReplaceOnDuplicateKey is True, then the existing item with the given key is removed from the Dictionary and replaced with the new item. If ReplaceOnDuplicateKey is False or omitted, the function will continue processing, but the item which caused the duplicate key condition will not be added to the Dictionary.

The procedure is shown below:

Function RangeToDictionary(KeyRange As Range, ItemRange As Range, Dict As Scripting.Dictionary, _
    Optional RangeAsObject As Boolean = False, _
    Optional StopOnDuplicateKey As Boolean = True, _
    Optional ReplaceOnDuplicateKey As Boolean = False) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RangeToDictionary
' This funciton loads an existing Dictionary Dict with the keys and value from
' worksheet ranges.
' The KeyRange and ItemRange must be the same size. Each element in KeyRange
' is the Key value for the corresponding item in ItemRange.
'
' If RangeAsObject is omitted of False, the Items added to the Dictionary are
' the values in the cells of ItemRange. If RangeAsObject is True, the cells
' are added as objects to the Dictionary.
'
' If a duplicate key is encountered when adding an item to Dict, the code
' will do one of the following:
'   If StopOnDuplicateKey is omitted or True, the funcion stops processing
'   and returns False. Items added to the Dictionary before the duplicate key
'   was encountered remain in the Dictionary.
'
'   If StopOnDuplicateKey is False, then if ReplaceOnDuplicateKey is False,
'   the Item that caused the duplicate key error is not added to the Dictionary
'   but processing continues with the rest of the items in the range. If
'   ReplaceOnDuplicateKey if True, the existing item in the Dictionary is
'   deleted and replaced with the new item.
'
' If Dict is Nothing, it will be created as a new Dictionary.
'
' The function returns True if all items were added to the dictionary, or False
' if an error occurred.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim KRng As Range
Dim KeyExists As Boolean
Dim ItemNdx As Long

'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Ensure the KeyRange and ItemRange variables are not
' Nothing.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If (KeyRange Is Nothing) Or (ItemRange Is Nothing) Then
    RangeToDictionary = False
    Exit Function
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Ensure KeyRange and ItemRange as the same size.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If (KeyRange.Rows.Count <> ItemRange.Rows.Count) Or _
    (KeyRange.Columns.Count <> ItemRange.Columns.Count) Then
    RangeToDictionary = False
    Exit Function
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Ensure both KeyRange and ItemRange are single area
' ranges.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If (KeyRange.Areas.Count > 1) Or (ItemRange.Areas.Count > 1) Then
    RangeToDictionary = False
    Exit Function
End If


'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If Dict is Nothing, create a new dictionary.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Dict Is Nothing Then
    Set Dict = New Scripting.Dictionary
End If

''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Loop through KeyRange, testing whether the Key exists
' and adding items to the Dictionary.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For Each KRng In KeyRange.Cells
    ItemNdx = ItemNdx + 1
    KeyExists = Dict.Exists(Key:=KRng.Text)
    If KeyExists = True Then
        '''''''''''''''''''''''''''''''''''''''''''
        ' The key already exists in the Dictionary.
        ' Determine what to do.
        '''''''''''''''''''''''''''''''''''''''''''
        If StopOnDuplicateKey = True Then
            RangeToDictionary = False
            Exit Function
        Else
            ''''''''''''''''''''''''''''''''''''''
            ' Do nothing here. Test the value of
            ' ReplaceOnDuplicateKey below.
            ''''''''''''''''''''''''''''''''''''''
        End If
        '''''''''''''''''''''''''''''''''''''''''
        ' If ReplaceOnDuplicateKey is True then
        ' remove the existing entry. Otherwise,
        ' exit the function.
        '''''''''''''''''''''''''''''''''''''''''
        If ReplaceOnDuplicateKey = True Then
            Dict.Remove Key:=KRng.Text
            KeyExists = False
        Else
            If StopOnDuplicateKey = True Then
                RangeToDictionary = False
                Exit Function
            End If
        End If
    End If
    If KeyExists = False Then
        If RangeAsObject = True Then
            Dict.Add Key:=KRng.Text, Item:=ItemRange.Cells(ItemNdx)
        Else
            Dict.Add Key:=KRng.Text, Item:=ItemRange.Cells(ItemNdx).Text
        End If
    End If
Next KRng

'''''''''''''''''
' Return Success.
'''''''''''''''''
RangeToDictionary = True

End Function

SortCollection

    Public Sub SortCollection(ByRef Coll As Collection, _
        Optional Descending As Boolean = False, _
        Optional CompareMode As VbCompareMethod = vbTextCompare)

This procedure sorts a Collection object  by the values of the items in the Collection. The Collection object must contain only simple variable types -- Objects, Arrays, and User-Define Types are not allowed. (If you want to sort a Collection that contains Object variables, use the CollectionToArray procedure described below, sort the array with the QSortObjectsInPlace procedure described on the Sorting Arrays Of Objects page, and then load the sorted array of objects back into a Collection.)

In this procedure, Coll is the collection that you want to sort, Descending indicates that the sort is to be in descending order (the default value of this parameter is False, sort in ascending order), and CompareMode indicates whether text comparisons are case-insensitive ("A" = "a", CompareMode = vbTextCompare) or case-sensitive ("A" <> "a", CompareMode = vbBinaryCompare). If CompareMode is omitted, it defaults to vbTextCompare for case-insensitive sorting.

One important caveat about sorting collections: Because there is no way to retrieve the Key of an Item in a collection (this is a limitation of the poor design of the Collection object), all your key values are lost when the Collection is sorted. If you need to preserve the keys, you should be using a Dictionary object rather than a Collection object in the first place. The procedure CollectionToDictionary described below will convert a Collection object to a Dictionary object, but you must supply the code that creates a unique key for each item in the Collection that will be used as the Key in the newly create Dictionary object.  The code for SortCollection is shown below:

Public Sub SortCollection(ByRef Coll As Collection, _
    Optional Descending As Boolean = False, _
    Optional CompareMode As VbCompareMethod = vbTextCompare)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SortCollection
' This sorts a collection by its items. It does not preserve
' the keys associated with the item. This limitation is due
' to the fact that Key is a write-only property. If you need
' sort by or preserve Keys, you should be using a Dictionary
' object rather than a Collection object. You can convert
' a Collection to a Dictionary with the function
' CollectionToDictionary. This procedure requires that you
' provide a funtion called CreateDictionaryKeyFromCollectionItem
' that creates a Dictionary Key from each Item in the
' Collection. This function may return vbNullString if
' keys are not being used.
'
' By default, string comparison are case-INSENSITIVE (e.g.,
' "a" = "A"). To sort case-SENSITIVE (e.g., "a" <> "A"), set
' the CompareMode parameter to vbBinaryCompare.
' By default, the items in Coll are sorted in ascending order.
' You can sort in descending order by setting the Descending
' parameter to True.
'
' The items in the collection must be simple data types.
' Objects, Arrays, and UserDefinedTypes are not allowed.
'
' Note: This procedure requires the
' QSortInPlace function, which is described and available for
' download at www.cpearson.com/excel/qsort.htm .
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim Arr() As Variant
Dim Ndx As Long

'''''''''''''''''''''''''''''''''''''
' Ensure that Coll is not Nothing.
'''''''''''''''''''''''''''''''''''''
If Coll Is Nothing Then
    Exit Sub
End If

''''''''''''''''''''''''''''''''''''''
' Ensure CompareMode is valid value.
''''''''''''''''''''''''''''''''''''''
Select Case CompareMode
    Case vbTextCompare, vbBinaryCompare
    Case Else
        Exit Sub
End Select


''''''''''''''''''''''''''''''''''''''
' If the number of elements in Coll
' is 0 or 1, no sorting is required.
' Get out.
''''''''''''''''''''''''''''''''''''''
If Coll.Count <= 1 Then
    Exit Sub
End If
ReDim Arr(1 To Coll.Count)
For Ndx = 1 To Coll.Count
    If IsObject(Arr(Ndx)) = True Or IsArray(Arr(Ndx)) = True Then
        Debug.Print "The items of the Collection cannot be arrays or objects."
        Exit Sub
    End If
    Arr(Ndx) = Coll(Ndx)
Next Ndx
''''''''''''''''''''''''''''''''''''''''''
' Sort the elements in the array. The
' QSortInPlace function is described on
' and downloadable from:
' http://www.cpearson.com/excel/qsort.htm
''''''''''''''''''''''''''''''''''''''''''
QSortInPlace InputArray:=Arr, LB:=-1, UB:=-1, _
    Descending:=Descending, CompareMode:=vbTextCompare
''''''''''''''''''''''''''''''''''''''''''
' Now reset Coll to a new, empty colletion.
''''''''''''''''''''''''''''''''''''''''''
Set Coll = Nothing
Set Coll = New Collection
''''''''''''''''''''''''''''''''''''''''''
' Load the array back into the new
' collection.
'''''''''''''''''''''''''''''''''''''''''
For Ndx = LBound(Arr) To UBound(Arr)
    Coll.Add Item:=Arr(Ndx)
Next Ndx

End Sub

SortDictionary

    Public Sub SortDictionary(Dict As Scripting.Dictionary, _
        SortByKey As Boolean, _
        Optional Descending As Boolean = False, _
        Optional CompareMode As VbCompareMethod = vbTextCompare)

This procedure sorts a Dictionary object, either by Key value or Item value. If SortByKey is True, then the Dictionary is sorted by the values of the Keys of Items in dictionary. In this case, the Dictionary may contain any type of data other than User Defined Types. It may include Object type variables. If SortByKey is False, the Dictionary is sorted by the value of the items in the Dictionary. In this case, the Dictionary may include only simple variable types. It may not contain objects, arrays, or User Define Types.  By default, the sort is in ascending order. Set the Descending parameter to True to sort in descending order. By default, text comparison are case-insensitive ("A" = "a"). To sort in case-sensitive mode ("A" <> "a"), set the CompareMode parameter to vbBinaryCompare. The code for SortDictionary is shown below:

Public Sub SortDictionary(Dict As Scripting.Dictionary, _
    SortByKey As Boolean, _
    Optional Descending As Boolean = False, _
    Optional CompareMode As VbCompareMethod = vbTextCompare)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SortDictionary
' This sorts a Dictionary object. If SortByKey is False, the
' the sort is done based on the Items of the Dictionary, and
' these items must be simple data types. They may not be
' Object, Arrays, or User-Defined Types. If SortByKey is True,
' the Dictionary is sorted by Key value, and the Items in the
' Dictionary may be Object as well as simple variables.
'
' If sort by key is True, all element of the Dictionary
' must have a non-blank Key value. If Key is vbNullString
' the procedure will terminate.
'
' By defualt, sorting is done in Ascending order. You can
' sort by Descending order by setting the Descending parameter
' to True.
'
' By default, text comparisons are done case-INSENSITIVE (e.g.,
' "a" = "A"). To use case-SENSITIVE comparisons (e.g., "a" <> "A")
' set CompareMode to vbBinaryCompare.
'
' Note: This procedure requires the
' QSortInPlace function, which is described and available for
' download at www.cpearson.com/excel/qsort.htm .
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim Ndx As Long
Dim KeyValue As String
Dim ItemValue As Variant
Dim Arr() As Variant
Dim KeyArr() As String
Dim VTypes() As VbVarType


Dim V As Variant
Dim SplitArr As Variant

Dim TempDict As Scripting.Dictionary
'''''''''''''''''''''''''''''
' Ensure Dict is not Nothing.
'''''''''''''''''''''''''''''
If Dict Is Nothing Then
    Exit Sub
End If
''''''''''''''''''''''''''''
' If the number of elements
' in Dict is 0 or 1, no
' sorting is required.
''''''''''''''''''''''''''''
If (Dict.Count = 0) Or (Dict.Count = 1) Then
    Exit Sub
End If

''''''''''''''''''''''''''''
' Create a new TempDict.
''''''''''''''''''''''''''''
Set TempDict = New Scripting.Dictionary

If SortByKey = True Then
    ''''''''''''''''''''''''''''''''''''''''
    ' We're sorting by key. Redim the Arr
    ' to the number of elements in the
    ' Dict object, and load that array
    ' with the key names.
    ''''''''''''''''''''''''''''''''''''''''
    ReDim Arr(0 To Dict.Count - 1)
    
    For Ndx = 0 To Dict.Count - 1
        Arr(Ndx) = Dict.Keys(Ndx)
    Next Ndx
    
    ''''''''''''''''''''''''''''''''''''''
    ' Sort the key names.
    ''''''''''''''''''''''''''''''''''''''
    QSortInPlace InputArray:=Arr, LB:=-1, UB:=-1, Descending:=Descending, CompareMode:=CompareMode
    ''''''''''''''''''''''''''''''''''''''''''''
    ' Load TempDict. The key value come from
    ' our sorted array of keys Arr, and the
    ' Item comes from the original Dict object.
    ''''''''''''''''''''''''''''''''''''''''''''
    For Ndx = 0 To Dict.Count - 1
        KeyValue = Arr(Ndx)
        TempDict.Add Key:=KeyValue, Item:=Dict.Item(KeyValue)
    Next Ndx
    '''''''''''''''''''''''''''''''''
    ' Set the passed in Dict object
    ' to our TempDict object.
    '''''''''''''''''''''''''''''''''
    Set Dict = TempDict
    ''''''''''''''''''''''''''''''''
    ' This is the end of processing.
    ''''''''''''''''''''''''''''''''
Else
    '''''''''''''''''''''''''''''''''''''''''''''''
    ' Here, we're sorting by items. The Items must
    ' be simple data types. They may NOT be Objects,
    ' arrays, or UserDefineTypes.
    ' First, ReDim Arr and VTypes to the number
    ' of elements in the Dict object. Arr will
    ' hold a string containing
    '   Item & vbNullChar & Key
    ' This keeps the association between the
    ' item and its key.
    '''''''''''''''''''''''''''''''''''''''''''''''
    ReDim Arr(0 To Dict.Count - 1)
    ReDim VTypes(0 To Dict.Count - 1)

    For Ndx = 0 To Dict.Count - 1
        If (IsObject(Dict.Items(Ndx)) = True) Or _
            (IsArray(Dict.Items(Ndx)) = True) Or _
            VarType(Dict.Items(Ndx)) = vbUserDefinedType Then
            Debug.Print "***** ITEM IN DICTIONARY WAS OBJECT OR ARRAY OR UDT"
            Exit Sub
        End If
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' Here, we create a string containing
        '       Item & vbNullChar & Key
        ' This preserves the associate between an item and its
        ' key. Store the VarType of the Item in the VTypes
        ' array. We'll use these values later to convert
        ' back to the proper data type for Item.
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            Arr(Ndx) = Dict.Items(Ndx) & vbNullChar & Dict.Keys(Ndx)
            VTypes(Ndx) = VarType(Dict.Items(Ndx))
            
    Next Ndx
    ''''''''''''''''''''''''''''''''''
    ' Sort the array that contains the
    ' items of the Dictionary along
    ' with their associated keys
    ''''''''''''''''''''''''''''''''''
    QSortInPlace InputArray:=Arr, LB:=-1, UB:=-1, Descending:=Descending, CompareMode:=vbTextCompare
    
    For Ndx = LBound(Arr) To UBound(Arr)
        '''''''''''''''''''''''''''''''''''''
        ' Loop trhogh the array of sorted
        ' Items, Split based on vbNullChar
        ' to get the Key from the element
        ' of the array Arr.
        SplitArr = Split(Arr(Ndx), vbNullChar)
        ''''''''''''''''''''''''''''''''''''''''''
        ' It may have been possible that item in
        ' the dictionary contains a vbNullChar.
        ' Therefore, use UBound to get the
        ' key value, which will necessarily
        ' be the last item of SplitArr.
        ' Then Redim Preserve SplitArr
        ' to UBound - 1 to get rid of the
        ' Key element, and use Join
        ' to reassemble to original value
        ' of the Item.
        '''''''''''''''''''''''''''''''''''''''''
        KeyValue = SplitArr(UBound(SplitArr))
        ReDim Preserve SplitArr(LBound(SplitArr) To UBound(SplitArr) - 1)
        ItemValue = Join(SplitArr, vbNullChar)
        '''''''''''''''''''''''''''''''''''''''
        ' Join will set ItemValue to a string
        ' regardless of what the original
        ' data type was. Test the VTypes(Ndx)
        ' value to convert ItemValue back to
        ' the proper data type.
        '''''''''''''''''''''''''''''''''''''''
        Select Case VTypes(Ndx)
            Case vbBoolean
                ItemValue = CBool(ItemValue)
            Case vbByte
                ItemValue = CByte(ItemValue)
            Case vbCurrency
                ItemValue = CCur(ItemValue)
            Case vbDate
                ItemValue = CDate(ItemValue)
            Case vbDecimal
                ItemValue = CDec(ItemValue)
            Case vbDouble
                ItemValue = CDbl(ItemValue)
            Case vbInteger
                ItemValue = CInt(ItemValue)
            Case vbLong
                ItemValue = CLng(ItemValue)
            Case vbSingle
                ItemValue = CSng(ItemValue)
            Case vbString
                ItemValue = CStr(ItemValue)
            Case Else
                ItemValue = ItemValue
        End Select
        ''''''''''''''''''''''''''''''''''''''
        ' Finally, add the Item and Key to
        ' our TempDict dictionary.
        
        TempDict.Add Key:=KeyValue, Item:=ItemValue
    Next Ndx
End If


'''''''''''''''''''''''''''''''''
' Set the passed in Dict object
' to our TempDict object.
'''''''''''''''''''''''''''''''''
Set Dict = TempDict
End Sub