VBA
Объект Scripting.Dictionary
Поиск…
замечания
Вы должны добавить Runtime Microsoft Scripting в проект VBA с помощью команды «Инструменты» → «Ссылки» VBE, чтобы реализовать раннее связывание объекта Scripting Dictionary. Эта библиографическая ссылка приводится в проекте; ему не нужно повторно ссылаться, когда проект VBA распространяется и запускается на другом компьютере.
Свойства и методы
Объект Scripting Dictionary хранит информацию в парах Key / Item. Ключи должны быть уникальными, а не массивом, но ассоциированные элементы могут быть повторены (их уникальность удерживается ключом компаньона) и может быть любого типа варианта или объекта.
Словарь можно рассматривать как базу данных с двумя полями в базе данных с основным уникальным индексом в первом «поле» ( Key ). Этот уникальный индекс в свойстве Keys позволяет очень быстро «искать» для получения значения связанного с ним элемента.
свойства
название | читай пиши | тип | описание |
---|---|---|---|
CompareMode | читай пиши | Константа CompareMode | Установка CompareMode может выполняться только в пустом словаре. Принятые значения: 0 (vbBinaryCompare), 1 (vbTextCompare), 2 (vbDatabaseCompare). |
подсчитывать | только для чтения | unsigned long integer | Однозначное количество пар ключей / элементов в объекте словаря сценариев. |
ключ | читай пиши | вариант без массива | Каждый отдельный уникальный ключ в словаре. |
Элемент ( Ключ ) | читай пиши | любой вариант | Свойство по умолчанию. Каждый отдельный элемент, связанный с ключом в словаре. Обратите внимание, что попытка получить элемент с ключом, который не существует в словаре, неявно добавит переданный ключ. |
методы
название | описание |
---|---|
Добавить ( ключ , элемент ) | Добавляет новый ключ и элемент в словарь. Новый ключ не должен существовать в текущей коллекции клавиш в словаре, но элемент можно повторить среди множества уникальных ключей. |
Существует ( ключ ) | Boolean test, чтобы определить, существует ли ключ в словаре. |
Ключи | Возвращает массив или набор уникальных ключей. |
Предметы | Возвращает массив или набор связанных элементов. |
Удалить ( ключ ) | Удаляет отдельный ключ словаря и связанный с ним элемент. |
Удалить все | Удаляет все ключи и элементы словарного объекта. |
Образец кода
'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
.
Заметки:
1. Предполагается, что данные находятся в ActiveWorkbook
.
2. Мы используем массив для вытягивания значений из листа; это более эффективно, чем повторение каждой ячейки.
3. Dictionary
создается с использованием раннего связывания.
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}
.
Примечание. Эта функция может использоваться с любым перечислимым объектом.