这段时间颇有点邯郸学步的感觉，由于把大量的时间和精力投入到python中，之前学的vba到想用的时候，居然忘了。

作为非程序员，编程向来当成"核导弹"来用，一次编写出来，能用，好，很难再有机会写第二遍代码了，因为问题解决了，以至于一直在遗忘的状态，再想用的时候到处翻资料，笔记。

VBA字典技术

VBA字典在日常统计工作中是个十分有用的技术，但是在写程序时，由于不熟练和个人记忆力有限，总要翻阅资料，于是产生将常用的字典技术汇集起来的想法。

一、入门篇

字典: 是为字词提供音韵、意思解释、例句、用法等等的工具书。

在VBA中字典与传统理解的字典差不多：

1、都具有关键字(key)和值(item)一一对应的关系，

2、键具有唯一性。

VBA字典的作用，与数组的结合运用，简化代码(其实是牺牲内存，空间换取时间的用法，但在现时代通用的电脑普遍内存够用的)，提升速度等一些强大的功能。

字典不存在与VBA中，需要调用，有两种方法：

1、前期绑定，在EXCEL表格开发工具中，工具-引用-浏览-找到scrrun.dll-确定；

2、后期绑定，直接用代码创建调用：Set d = CreateObject("scripting.dictionary")

本文主要采用后期绑定方式记录字典用法。

字典对象的方法有6个：

Add 添加一条关键字与条目

Keys 返回所有关键字(形成1维数组)

Items 返回所有条目(形成1维数组)

Exists 关键字是否存在(TRUE/FALSE)

Remove 移除关键字与对应的条目

RemoveAll 移除所有关键字与对应的条目

向 Dictionary 对象中添加一个关键字项目对。

语法：object.Add (key, item)

Key，必选项。与被添加的 item 相关联的 key。

Item，必选项。与被添加的 key 相关联的 item。

key 是唯一存在的，否则将导致一个错误。

实例1:Sub kaishi()

'字典的键索引从零开始为第一个键

Dim d As New Dictionary, i, j, k, l

Set d = CreateObject("scripting.dictionary")

d.Add "张三", "15"

d.Add "李四", "18"

‘基础取值方法

i = d.Keys(0)

j = Application.WorksheetFunction.Index(d.Keys, 2)

k = d.Keys ’keys会返回一个数组，所以可以用Index方法取值

l = k(1)

'Exists方法

'如果 Dictionary 对象中存在所指定的关键字则返回 true，否则返回 false。

' a = d.Exists("李四")

'Remove方法

'Remove 方法从一个 Dictionary 对象中清除一个键——值对。

d.Remove ("李四")

'RemoveAll方法

'RemoveAll 方法从一个 Dictionary 对象中清除所有键——值对。

d.RemoveAll

End Sub

字典对象的属性有4个：

CompareMode属性

Count属性

Key属性

Item属性

实例2：Sub test()

Set d = CreateObject("scripting.dictionary")

'1.CompareMode属性

'设置或者返回在 Dictionary 对象中进行字符串关键字比较时所使用的比较模式。

d.CompareMode = 0 '1则不区分大小写，0则区分大小写，默认为1

d.Add "a", ""

d.Add "A", ""

d.Add "张三", "13434544323"

d.Add "李四", "13589898999"

d.Add "王五", "13456565567"

'2.Count属性

'返回一个Dictionary 对象中的项目数.只读属性

k = d.Count

'3.Key属性

'在 Dictionary 对象中修改一个 key。

d.Key("王五") = "牛三斤"

'4.Item属性

'在一个 Dictionary 对象中设置或者返回所指定 key 的 item。对于集合则根据所指定的 key 返回一个 item。

i = d.Items

d.Item("张三") = "112233"

i = d.Items

d("张三") = 987 '简写方式

i = d.Items

'注意：容易混淆知识点。d.key("a")与d("a")

End Sub

二、实战篇

实例3：第一次与最后一次采购价格提取

在VBA中，字典的键具有唯一性，采用add方法，如果有重复的键则会发生错误，根据这一特性，可以提取到第一次出现的键——值对。

而采用d.item(key)=value替换方法，新的键——值对会替换掉之前的键——值对，从而提取到最后一次键——值对。

由于d.keys与d.items都会形成标准的一维数组，在写入纵向的单元格时，需要通过transpose进行转置。

'求每种产品第一次采购价

Sub first()

Dim arr()

On Error Resume Next

Set d = CreateObject("scripting.dictionary")

arr = Range("b1:c" & Cells(Rows.Count, 3).End(xlUp).Row)

For i = 1 To UBound(arr)

d.Add arr(i, 1), arr(i, 2)

Next

[e1].Resize(d.Count) = Application.Transpose(d.keys)

[f1].Resize(d.Count) = Application.Transpose(d.items)

End Sub

'求每种产品最后一次采购价

Sub last()

Dim arr()

Set d = CreateObject("scripting.dictionary")

arr = Range("b1:c" & Cells(Rows.Count, 3).End(xlUp).Row)

For i = 1 To UBound(arr)

d(arr(i, 1)) = arr(i, 2)

Next

[i1].Resize(d.Count) = Application.Transpose(d.keys)

[j1].Resize(d.Count) = Application.Transpose(d.items)

End Sub

实例4：多表求不重复值

值得一提的是d(key)=value方法，没有就写入，有就替换，而且并不会随着循环的改变清空其中的键——值对。

Sub test()

Set d = CreateObject("scripting.dictionary")

For Each sh In Sheets

c = sh.Name

If sh.Name <> "品名" Then

arr = sh.Range("a1:a" & sh.Cells(Rows.Count, 1).End(xlUp).Row)

For Each Rng In arr

d(Rng) = ""

Next

End If

Next

[a1].Resize(d.Count) = Application.Transpose(d.keys)

End Sub

实例5：字典与数组的结合运用

Sub test()

Set d = CreateObject("scripting.dictionary")

arr = Sheet1.Range("a1:b" & Sheet1.Cells(Rows.Count, "a").End(xlUp).Row)

For Each Rng In arr

arr1 = VBA.Split(Rng, "|")

For Each rngs In arr1

d(rngs) = ""

Next

i = VBA.Join(d.keys, "|")

n = n + 1

Sheet2.Cells(n, "a") = i

d.RemoveAll’清除本次循环的键值对

Next

End Sub

实例6：分类计算

字典可以通过键对应空值d(key)=d(key)+1，形成迭代计算从而统计出重复键出现次数。

而d(key)=d(key)+value，形成替换累加效果。

Sub 分类计数()

Dim arr1

Set d = CreateObject("scripting.dictionary")

arr = Range("b2:b" & Cells(Rows.Count, 2).End(xlUp).Row)

For Each Rng In arr

i = d(Rng)

d(Rng) = d(Rng) + 1

i = d(Rng)

Next

[e1].Resize(d.Count) = Application.Transpose(d.keys)

[f1].Resize(d.Count) = Application.Transpose(d.items)

End Sub

Sub 分类求和()

Dim arr1

Set d = CreateObject("scripting.dictionary")

arr = Range("b2:c" & Cells(Rows.Count, 2).End(xlUp).Row)

For i = 1 To UBound(arr)

d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2)

Next

[e8].Resize(d.Count) = Application.Transpose(d.keys)

[f8].Resize(d.Count) = Application.Transpose(d.items)

End Sub

实例7：多列合并计算

此例在逻辑上挺绕的，由于定义的动态数组arr(1 to 4, 1 to n),二维数组的第一维的下限不能为不确定值的变量，所以通过多层转置达到取值的目的。

Dim arr1()

Set d = CreateObject("scripting.dictionary")

arr = Range("a2:d" & Cells(Rows.Count, 2).End(xlUp).Row)

For i = 1 To UBound(arr)

If Not d.exists(arr(i, 1)) Then

n = n + 1

d(arr(i, 1)) = n

ReDim Preserve arr1(1 To 4, 1 To n)

arr1(1, n) = arr(i, 1)

arr1(2, n) = arr(i, 2)

arr1(3, n) = arr(i, 3)

arr1(4, n) = arr(i, 4)

Else

m = d(arr(i, 1))

arr1(2, m) = arr1(2, m) + arr(i, 2)

arr1(3, m) = arr1(3, m) + arr(i, 3)

arr1(4, m) = arr1(4, m) + arr(i, 4)

End If

Next

[f2].Resize(n, 4) = Application.Transpose(arr1)

End Sub

实例8：条目数组用法

字典的键——值方式非常的灵活，值甚至可以是数组。

Sub test() '条目数组用法

Set d = CreateObject("scripting.dictionary")

With Sheets("data")

arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(xlUp).Row)

End With

For i = 1 To UBound(arr)

d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5))

j = d(arr(i, 1))

Next

For Each Rng In Range("a3:a" & Cells(Rows.Count, 1).End(xlUp).Row)

Rng.Offset(0, 1).Resize(1, 4) = d(Rng.Value)

Next

End Sub

总结:

字典在VBA中是种非常实用的技术，在实际运用中，与事件，控件等功能结合运用会产生一些非常实用神奇的操作。