VBA 字典实例

1，特殊条件编号

‘2012-9-3

‘http://club.excelhome.net/forum.php?mod=viewthread&tid=914702&page=1#pid6271907

Sub lqxs()

Dim Arr, i&, j&, jj&, n&, aa, bb, y, x$

Dim d As New Dictionary, k, t, d1 As New Dictionary, t1

Sheet1.Activate

[e31:e5000].ClearContents

d1(x)(y) = d1(x)(y) & i & ","

Next

k = d.keys

t = d.items

For i = 0 To UBound(k)

t(i) = Left(t(i), Len(t(i)) - 1)

n = 0

If InStr(t(i), ",") Then

aa = Split(t(i), ",")

For j = 0 To UBound(aa)

For jj = 0 To UBound(bb)

Cells(bb(jj), 5) = n

Next

j = j + UBound(bb)

Else

Cells(t1, 5) = n

End If

Next

End If

Next

‘2012-9-4

‘http://club.excelhome.net/thread-716135-1-1.html

Dim d1 As New Dictionary

Dim d2 As New Dictionary

Private Sub ComboBox2_Click()

ComboBox3 = ""

ComboBox3.List = d2(ComboBox1.Text & ComboBox2.Text).Items

End Sub

Private Sub UserForm_Initialize()

arr = Sheet1.Range("a3:f" & Sheet1.[a65536].End(3).Row)

For i = 1 To UBound(arr)

a = arr(i, 1) & "": b = arr(i, 3) & "": c = arr(i, 6) & ""

ComboBox1.List = d1.Keys

End Sub

Dim d1 As New Dictionary

Sub 填充()

Dim xm, rkb, rkkm, rlkm, rlxm, r, sckm, km, s

Sheet2.Activate

[b:c].ClearContents

rkb = Sheets("任课表").Range("b2:bi16")

xm = Sheets("绩效名单").Range("a2:a241")

rkkm = Sheets("任课表").Range("a2:a16")

For i = 1 To UBound(rkb)

For j = 1 To UBound(rkb, 2)

For x = 1 To UBound(xm)

If d.exists(xm(x, 1)) Then

s = d(xm(x, 1)).items

If IsArray(s) Then

Cells(x + 1, 2).Resize(1, UBound(s) + 1) = s

Else

Cells(x + 1, 2) = s

End If

End If

Next

‘http://club.excelhome.net/thread-984445-1-1.html

Set d = CreateObject("Scripting.Dictionary")

Arr = [a1].CurrentRegion

For i = 2 To UBound(Arr)

x = Arr(i, 1): y = Arr(i, 2)

If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")

d(x)(y) = d(x)(y) + 1

Next

k = d.keys

t = d.items:

For i = 2 To UBound(Arr)

Dim Arr, i&, j&, n&, tt

Dim d, k, t, d1, x, y, k1

Set d = CreateObject("Scripting.Dictionary")

Set d1 = CreateObject("Scripting.Dictionary")

Sheet2.Activate

Arr = Sheet1.[a1].CurrentRegion

For i = 2 To UBound(Arr)

x = Arr(i, 1)

y = Left(Arr(i, 3), 1)

d(x) = d(x) + 1

Cells(n, 1) = "小计"

Cells(n, 2) = k(i)

Cells(n, 3) = t(i).Count

tt = tt + t(i).Count

k1 = t(i).keys

For j = 0 To UBound(k1)

n = n + 1

Cells(n, 2) = k(i)

n = n + 1

Next

Cells(3, 3) = tt

End Sub

5，3 级字典嵌套

Set d = CreateObject("Scripting.Dictionary")

Set d1 = CreateObject("Scripting.Dictionary")

Sheet3.Activate

[a2:d50000].Clear

Arr1 = Sheet1.[a1].CurrentRegion

Arr = Sheet2.[a1].CurrentRegion

For i = 2 To UBound(Arr)

a = Arr(i, 4): b = Arr(i, 3)

d(b) = a

Next

If d.Exists(a) = False Then Set d(a) = CreateObject("Scripting.Dictionary")

d(a)(b) = b

If d1.Exists(cp) = False Then

Set d1(cp) = CreateObject("Scripting.Dictionary")

End If

d1(cp)(c) = d1(cp)(c) + 1

End If

Next

k = d.keys: k1 = d1.keys