MyTetra Share
Делитесь знаниями!
Dic
06.10.2017
14:11
Текстовые метки: Dictionary
Раздел: VBA


Option Explicit



Sub Creation()

' ВАРИАНТ 1 - раннее связывание

' ------------------------------------------------------

' декларируем объектную переменную

Dim dicTemp1 As Dictionary ' нужно, если есть опция Option Explicit

' либо можно так: Dim dicTemp1

' либо так: Dim dicTemp1 as Object

' создаём объект и присваиваем ссылку на него переменной

Set dicTemp1 = New Dictionary

' проверяем что объект работает, выводя количество элементов

' сейчас их там, конечно же, нет ни одного

MsgBox dicTemp1.Count

' ВАРИАНТ 2 - раннее связывание

' ------------------------------------------------------

' декларируем и сразу создаём объект

Dim dicTemp2 As New Dictionary

' проверяем что объект работает

MsgBox dicTemp2.Count

' ВАРИАНТ 3 - раннее связывание (без переменной)

' ------------------------------------------------------

With New Dictionary

MsgBox .Count

End With

' ВАРИАНТ 4 - позднее связывание

' ------------------------------------------------------

Dim dicTemp4 ' нужно, если есть опция Option Explicit

Set dicTemp4 = CreateObject("Scripting.Dictionary")

' ВАРИАНТ 5 - позднее связывание (без переменной)

' ------------------------------------------------------

With CreateObject("Scripting.Dictionary")

MsgBox .Count

End With

End Sub



Sub HowToAddElement()


Dim dicCountry, row As Integer

Dim key As String, Item As Double

Set dicCountry = CreateObject("Scripting.Dictionary")

With Sheets("Example").Range("SquareByCountry")

For row = 1 To .Rows.Count

key = CStr(.Cells(row, 1).Value)

Item = CDbl(.Cells(row, 2).Value)

dicCountry.Add key, Item

Next

End With


End Sub



Sub HowToAddElement2()


Dim dicCountry, row As Integer

Dim key As String, Item As Double

Set dicCountry = CreateObject("Scripting.Dictionary")

With Sheets("Example").Range("SquareByCountry")

For row = 1 To .Rows.Count

key = CStr(.Cells(row, 1).Value)

Item = CDbl(.Cells(row, 2).Value)

dicCountry.Item(key) = Item

Next

End With


End Sub



Sub ImplicitKeyAddition()


Dim dicCountry, row As Integer

Dim key As String

Dim varTemp

Set dicCountry = CreateObject("Scripting.Dictionary")

With Sheets("Example").Range("SquareByCountry")

For row = 1 To .Rows.Count

key = CStr(.Cells(row, 1).Value)

varTemp = dicCountry.Item(key)

Next

End With


End Sub


Sub ShowDifferentKeys()


On Error Resume Next


Dim dicTemp As New Dictionary

Dim strShow As String, key As Variant


dicTemp.Add Date, "Date type" ' добавляем ключ с типом дата

dicTemp.Add True, "Boolean type" ' добавляем ключ с логическим типом

dicTemp.Add CDbl(12.4567), "Double type" ' добавляем ключ с типом Double

dicTemp.Add CInt(12999), "Integer type" ' добавляем ключ с типом Integer

dicTemp.Add "Red", "String type" ' добавляем строковый ключ

dicTemp.Add ActiveSheet, "Worksheet object" ' добавляем ключ в виже Worksheet объекта


For Each key In dicTemp.Keys ' перебираем ключи словаря (тут немного забегаю вперёд)

Err.Clear ' очищаю ошибку

' Для каждого элемента словаря формирую строку ключ - тип ключа

' Тип ключа выясняем при помощи функции TypeName

strShow = strShow & CStr(key) & vbTab & vbTab & TypeName(key) & vbCr

' Поскольку у нас один из ключей имеет объектный тип, то CStr(key) выдаст ошибку

' которую мы перехватим и CStr(key) заменим на key.Name

If Err Then strShow = strShow & key.Name & vbTab & vbTab & TypeName(key) & vbCr

Next

' Выведем на экран результат

MsgBox strShow, vbInformation, "Он реально хранит типы ключей!"


End Sub



Sub ShowCompareMode()

On Error Resume Next

With New Dictionary

.CompareMode = TextCompare ' текстовый режим - игнорирует регистр

.Add "Россия", 17098

.Add "РоссиЯ", 17098 ' тут будет сгенерировано исключение

MsgBox Join(.Keys, vbLf), , "Россия и РоссиЯ"

.RemoveAll 'очищаем словарь, иначе изменение CompareMode вызовет ошибку

.CompareMode = BinaryCompare ' двоичный режим - различает регистр

.Add "США", 9519

.Add "Сша", 9519 ' будут добавлены оба элемента

MsgBox Join(.Keys, vbLf), , "США и Сша"

End With

End Sub


Sub ShowUniqKeys()

Dim Element

With CreateObject("Scripting.Dictionary")

For Each Element In Array("Один", "Два", "Три", "Четыре", "Пять")

' Используем Count в качестве значения ключа

' таким образом ключи будут 0,1,2,3,4

.Item(.Count) = Element

Next

MsgBox Join(.Keys, vbLf)

End With

End Sub


Sub ShowDifferentItems()


Dim dicTemp As New Dictionary

Dim strShow As String, Item As Variant


With dicTemp

.Add .Count, Date ' добавляем элемент с типом дата

.Add .Count, True ' добавляем элемент с логическим типом

.Add .Count, CDbl(12.4567) ' добавляем элемент с типом Double

.Add .Count, CInt(12999) ' добавляем элемент с типом Integer

.Add .Count, "Red" ' добавляем строковый элемент

.Add .Count, ActiveSheet ' добавляем элемент в виде Worksheet объекта

.Add .Count, Array(11, 22, 33) ' добавляем элемент типа массив

For Each Item In .Items ' перебираем элементы словаря (тут немного забегаю вперёд)

Err.Clear ' очищаю ошибку

' Для каждого элемента словаря формирую строку c типом элемента

' Тип элемента выясняем при помощи функции TypeName

strShow = strShow & TypeName(Item) & vbCr

Next

End With

' Выведем на экран результат

MsgBox strShow, vbInformation, "Он реально хранит типы элементов!"


End Sub



Sub UDT_through_Class()

Dim objRGB As MyRGB ' объявляем переменную с типом нашего класса

Set objRGB = New MyRGB ' создаём наш объект

' Присваиваем какие-то значения

objRGB.Red = 100

objRGB.Green = 150

objRGB.Blue = 200

With New Dictionary ' создаём словарь

.Add "test", objRGB ' добавляем в качестве элемента наш объект

' Теперь мы можем обращаться к отдельным свойствам данного элемента словаря

' в частности, мы тут прочли красную ("Red") компоненту структуры

MsgBox "К примеру, красная компонента равна " & .Item("test").Red

End With

End Sub


Sub Get_Item_By_Key()

With New Dictionary

.Add "Россия", 17098 ' добавляем элемент

MsgBox .Item("Россия") ' и извлекаем элемент

End With

End Sub


Sub Get_Item_By_Index()

Dim dicTemp As New Dictionary ' объявляем и сразу создаём словарь

Dim varCountry As Variant ' вспомогательная переменная

With dicTemp ' работаем со словарём

' Организуем цикл по массиву из 5 элементов

For Each varCountry In Array("Russia", "Canada", "China", "USA", "Brazil")

' наполняем словарь парами вида "Key 1" - "Russia", "Key 2" - "Canada"

.Item("Key " & CStr(.Count + 1)) = varCountry ' используем способ из 4.3.

Next

' Извлекаем элементы по их индексу! Обратите внимание на синтаксис!

' наиболее неожиданно тут то, что после Items надо использовать пустые скобки

MsgBox .Items()(0) ' вернёт Russia, так как нумерация начинается с нуля

MsgBox .Items()(3) ' вернёт USA

MsgBox .Items()(.Count - 1) ' классика - последний элемент!

MsgBox .Items()(UBound(.Keys)) ' немного экзотики - тоже последний элемент :)

End With

End Sub


Sub Loop_1()

Dim dicTemp As New Dictionary

Dim varCountry As Variant

Dim varKey As Variant, varItem As Variant

Dim strShow As String

With dicTemp

For Each varCountry In Array("Russia", "Canada", "China", "USA", "Brazil")

.Item("Key " & CStr(.Count + 1)) = varCountry

Next

For Each varKey In .Keys ' организуем цикл по элементам масива Keys

strShow = strShow & .Item(varKey) & vbLf

Next

MsgBox strShow, vbInformation, "Цикл по Keys"

strShow = vbNullString

For Each varItem In .Items ' организуем цикл по элементам масива Items

strShow = strShow & varItem & vbLf

Next

MsgBox strShow, vbInformation, "Цикл по Items"

End With

End Sub



Sub Loop_2()

Dim dicTemp As New Dictionary

Dim varCountry As Variant

Dim strShow As String, i As Integer

With dicTemp

For Each varCountry In Array("Russia", "Canada", "China", "USA", "Brazil")

.Item("Key " & CStr(.Count + 1)) = varCountry

Next

For i = 0 To .Count - 1

strShow = strShow & .Items()(i) & vbLf

Next

MsgBox strShow, vbInformation, "Цикл по Items"

strShow = vbNullString

For i = 0 To .Count - 1

strShow = strShow & .Keys()(i) & vbLf

Next

MsgBox strShow, vbInformation, "Цикл по Keys"

End With

End Sub



Sub Filter_1()

Dim dicTemp As New Dictionary

Dim varCountry As Variant

Dim varItem As Variant

With dicTemp

For Each varCountry In Array("Russia", "Canada", "China", "USA", "Brazil")

.Item("Key " & CStr(.Count + 1)) = varCountry

Next

' Используем метод Filter объекта Application!

For Each varItem In Filter(.Items, "r", , vbTextCompare)

MsgBox varItem ' будет отфильтрованы Russia и Brazil

Next

End With

End Sub



Sub Fill_Range()

Dim dicTemp As New Dictionary

Dim varCountry As Variant

Dim varItem As Variant

With dicTemp

For Each varCountry In Array("Russia", "Canada", "China", "USA", "Brazil")

.Item("Key " & CStr(.Count + 1)) = varCountry

Next

' вытягиваем элементы по строке

Cells(1, 1).Resize(, .Count) = .Keys

Cells(2, 1).Resize(, .Count) = .Items


' вытягиваем элементы по столбцу

Cells(4, 1).Resize(.Count) = Application.Transpose(.Keys)

Cells(4, 2).Resize(.Count) = Application.Transpose(.Items)


End With

End Sub



Sub Operations_with_Keys()

Dim dicTemp As New Dictionary

Dim arrItems, arrKeys

Dim i As Integer

With dicTemp

' определяем массивы для ключей и элементов

arrKeys = Array(17098, 9976, 9598, 9519, 8511)

arrItems = Array("Russia", "Canada", "China", "USA", "Brazil")

' добавляем массивы в словарь

For i = 0 To UBound(arrKeys)

.Add arrKeys(i), arrItems(i)

Next

' находим максимальное значение ключа, а по ключу извлекаем элемент (название страны)

MsgBox .Item(Application.WorksheetFunction.Max(.Keys)) & " has the largest territory."


End With

End Sub


Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования