VBA
Объект Scripting.Dictionary

замечания

Свойства и методы

Объект Scripting Dictionary хранит информацию в парах Key / Item. Ключи должны быть уникальными, а не массивом, но ассоциированные элементы могут быть повторены (их уникальность удерживается ключом компаньона) и может быть любого типа варианта или объекта.

Словарь можно рассматривать как базу данных с двумя полями в базе данных с основным уникальным индексом в первом «поле» ( Key ). Этот уникальный индекс в свойстве Keys позволяет очень быстро «искать» для получения значения связанного с ним элемента.

свойства

методы

Образец кода

'Populate, enumerate, locate and remove entries in a dictionary that was created
'with late binding
Sub iterateDictionaryLate()
    Dim k As Variant, dict As Object
    
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare          'non-case sensitive compare model
    
    'populate the dictionary
    dict.Add Key:="Red", Item:="Balloon"
    dict.Add Key:="Green", Item:="Balloon"
    dict.Add Key:="Blue", Item:="Balloon"
    
    'iterate through the keys
    For Each k In dict.Keys
        Debug.Print k & " - " & dict.Item(k)
    Next k

    'locate the Item for Green
    Debug.Print dict.Item("Green")
    
    'remove key/item pairs from the dictionary
    dict.Remove "blue"      'remove individual key/item pair by key
    dict.RemoveAll          'remove all remaining key/item pairs

End Sub

'Populate, enumerate, locate and remove entries in a dictionary that was created
'with early binding (see Remarks)
Sub iterateDictionaryEarly()
    Dim d As Long, k As Variant
    Dim dict As New Scripting.Dictionary
    
    dict.CompareMode = vbTextCompare          'non-case sensitive compare model
    
    'populate the dictionary
    dict.Add Key:="Red", Item:="Balloon"
    dict.Add Key:="Green", Item:="Balloon"
    dict.Add Key:="Blue", Item:="Balloon"
    dict.Add Key:="White", Item:="Balloon"
    
    'iterate through the keys
    For Each k In dict.Keys
        Debug.Print k & " - " & dict.Item(k)
    Next k

    'iterate through the keys by the count
    For d = 0 To dict.Count - 1
        Debug.Print dict.Keys(d) & " - " & dict.Items(d)
    Next d
    
    'iterate through the keys by the boundaries of the keys collection
    For d = LBound(dict.Keys) To UBound(dict.Keys)
        Debug.Print dict.Keys(d) & " - " & dict.Items(d)
    Next d
    
    'locate the Item for Green
    Debug.Print dict.Item("Green")
    'locate the Item for the first key
    Debug.Print dict.Item(dict.Keys(0))
    'locate the Item for the last key
    Debug.Print dict.Item(dict.Keys(UBound(dict.Keys)))
    
    'remove key/item pairs from the dictionary
    dict.Remove "blue"                         'remove individual key/item pair by key
    dict.Remove dict.Keys(0)                   'remove first key/item by index position
    dict.Remove dict.Keys(UBound(dict.Keys))   'remove last key/item by index position
    dict.RemoveAll                             'remove all remaining key/item pairs

End Sub

Агрегация данных с помощью Scripting.Dictionary (Maximum, Count)

Словари отлично подходят для управления информацией, в которой происходит несколько записей, но для каждого набора записей используется только одно значение - первое или последнее значение, минимальное или максимальное значение, среднее значение, сумма и т. Д.

Рассмотрим книгу, в которой хранится журнал активности пользователя, со сценарием, который вставляет имя пользователя и дату редактирования каждый раз, когда кто-то редактирует книгу:

Log лист

	В
боб	10/12/2016 9:00
Алиса	13.10.2013 13:00
боб	13.10.2006 13:30
Алиса	13.10.2016 14:00
Алиса	14.10.2013 13:00

Предположим, вы хотите вывести последнее время редактирования для каждого пользователя в рабочий лист с именем Summary .

<sup>Заметки:
1. Предполагается, что данные находятся в ActiveWorkbook .
2. Мы используем массив для вытягивания значений из листа; это более эффективно, чем повторение каждой ячейки.
3. Dictionary создается с использованием раннего связывания.</sup>

Sub LastEdit()
Dim vLog as Variant, vKey as Variant
Dim dict as New Scripting.Dictionary
Dim lastRow As Integer, lastColumn As Integer
Dim i as Long
Dim anchor As Range

With ActiveWorkbook
    With .Sheets("Log")
        'Pull entries in "log" into a variant array
        lastRow = .Range("a" & .Rows.Count).End(xlUp).Row
        vlog = .Range("a1", .Cells(lastRow, 2)).Value2

        'Loop through array
        For i = 1 to lastRow
            Dim username As String
            username = vlog(i, 1)
            Dim editDate As Date
            editDate = vlog(i, 2)

            'If the username is not yet in the dictionary:
            If Not dict.Exists(username) Then
                dict(username) = editDate
            ElseIf dict(username) < editDate Then
                dict(username) = editDate
            End If
        Next
    End With

    With .Sheets("Summary")
        'Loop through keys
        For Each vKey in dict.Keys
            'Add the key and value at the next available row
            Anchor = .Range("A" & .Rows.Count).End(xlUp).Offset(1,0)
            Anchor = vKey
            Anchor.Offset(0,1) = dict(vKey)
        Next vKey
    End With
End With
End Sub

и выход будет выглядеть так:

Summary рабочий лист

	В
боб	13.10.2006 13:30
Алиса	14.10.2013 13:00

Если, с другой стороны, вы хотите вывести, сколько раз каждый пользователь редактировал книгу, тело цикла For должно выглядеть так:

        'Loop through array
        For i = 1 to lastRow
            Dim username As String
            username = vlog(i, 1)

            'If the username is not yet in the dictionary:
            If Not dict.Exists(username) Then
                dict(username) = 1
            Else
                dict(username) = dict(username) + 1
            End If
        Next

и выход будет выглядеть так:

Summary рабочий лист

	В
боб	2
Алиса	3

Получение уникальных значений с помощью Scripting.Dictionary

Dictionary позволяет очень просто получить уникальный набор значений. Рассмотрим следующую функцию:

Function Unique(values As Variant) As Variant()
    'Put all the values as keys into a dictionary
    Dim dict As New Scripting.Dictionary
    Dim val As Variant
    For Each val In values
        dict(val) = 1 'The value doesn't matter here
    Next
    Unique = dict.Keys
End Function

который вы могли бы затем вызвать следующим образом:

Dim duplicates() As Variant
duplicates = Array(1, 2, 3, 1, 2, 3)
Dim uniqueVals() As Variant
uniqueVals = Unique(duplicates)

и uniqueVals будет содержать только {1,2,3} .

Примечание. Эта функция может использоваться с любым перечислимым объектом.