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