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 Arr = [a1].CurrentRegion For i = 31 To UBound(Arr) x = Arr(i, 4)

y = Arr(i, 1) & \ d(x) = d(x) & i & \

If d1.Exists(x) = False Then Set d1(x) = New Dictionary 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), \ aa = Split(t(i), \

For j = 0 To UBound(aa)

y = Arr(aa(j), 1) & \ n = n + 1

t1 = d1(k(i))(y)

t1 = Left(t1, Len(t1) - 1) If InStr(t1, \ bb = Split(t1, \

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 End Sub

2，列表框3级数据有效性

‘2012-9-4

‘http://club.excelhome.net/thread-716135-1-1.html Dim d1 As New Dictionary Dim d2 As New Dictionary

Private Sub ComboBox1_Click() ComboBox2.Clear ComboBox3.Clear

ComboBox2.List = d1(ComboBox1.Text).Items End Sub

Private Sub ComboBox2_Click() ComboBox3 = \

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

Private Sub UserForm_Initialize()

arr = Sheet1.Range(\For i = 1 To UBound(arr)

a = arr(i, 1) & \x = arr(i, 1) & arr(i, 3)

If d1.Exists(a) = False Then Set d1(a) = New Dictionary d1(a)(b) = b

If d2.Exists(x) = False Then Set d2(x) = New Dictionary d2(x)(c) = c Next

ComboBox1.List = d1.Keys End Sub

3，填表

‘2012-9-19

‘http://club.excelhome.net/thread-922624-1-1.html Dim d As New Dictionary Dim d1 As New Dictionary Sub 填充()

Dim xm, rkb, rkkm, rlkm, rlxm, r, sckm, km, s Sheet2.Activate [b:c].ClearContents

rkb = Sheets(\任课表\xm = Sheets(\绩效名单\rkkm = Sheets(\任课表\For i = 1 To UBound(rkb)

For j = 1 To UBound(rkb, 2)

If d.exists(rkb(i, j)) = False Then Set d(rkb(i, j)) = New Dictionary d(rkb(i, j))(rkkm(i, 1)) = rkkm(i, 1) Next j Next i k = d.Keys

k1 = d(k(0)).items

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

Set d = Nothing End Sub

4，2级字典嵌套

‘2013-2-21

‘http://club.excelhome.net/thread-984445-1-1.html Sub lqxs()

Dim Arr, i&, x, y Dim d, k, t

Set d = CreateObject(\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(\ d(x)(y) = d(x)(y) + 1 Next

k = d.keys