VBA字典用法

1，特殊条件编号‘2012-9-3‘/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, t1Sheet1.Activate[e31:e5000].ClearContentsArr = [a1].CurrentRegionFor i = 31 To UBound(Arr)x = Arr(i, 4)y = Arr(i, 1) & "|" & Arr(i, 3)d(x) = d(x) & i & ","If d1.Exists(x) = False Then Set d1(x) = New Dictionaryd1(x)(y) = d1(x)(y) & i & ","Nextk = d.keyst = d.itemsFor i = 0 To UBound(k)t(i) = Left(t(i), Len(t(i)) - 1)n = 0If InStr(t(i), ",") Thenaa = Split(t(i), ",")For j = 0 To UBound(aa)y = Arr(aa(j), 1) & "|" & Arr(aa(j), 3)n = n + 1t1 = d1(k(i))(y)t1 = Left(t1, Len(t1) - 1)If InStr(t1, ",") Thenbb = Split(t1, ",")For jj = 0 To UBound(bb)Cells(bb(jj), 5) = nNextj = j + UBound(bb)ElseCells(t1, 5) = nEnd IfNextEnd IfNextEnd Sub2，列表框3级数据有效性‘2012-9-4‘/thread-716135-1-1.htmlDim d1 As New DictionaryDim d2 As New DictionaryPrivate Sub ComboBox1_Click()ComboBox2.ClearComboBox3.ClearComboBox2.List = d1(ComboBox1.Text).ItemsEnd SubPrivate Sub ComboBox2_Click()ComboBox3 = ""ComboBox3.List = d2(ComboBox1.Text & ComboBox2.Text).Items End SubPrivate 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) & ""x = arr(i, 1) & arr(i, 3)If d1.Exists(a) = False Then Set d1(a) = New Dictionary d1(a)(b) = bIf d2.Exists(x) = False Then Set d2(x) = New Dictionary d2(x)(c) = cNextComboBox1.List = d1.KeysEnd Sub3，填表‘2012-9-19‘/thread-922624-1-1.htmlDim d As New DictionaryDim d1 As New DictionarySub 填充()Dim xm, rkb, rkkm, rlkm, rlxm, r, sckm, km, sSheet2.Activate[b:c].ClearContentsrkb = 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)If d.exists(rkb(i, j)) = False Then Set d(rkb(i, j)) = New Dictionaryd(rkb(i, j))(rkkm(i, 1)) = rkkm(i, 1)Next jNext ik = d.Keysk1 = d(k(0)).itemsFor x = 1 To UBound(xm)If d.exists(xm(x, 1)) Thens = d(xm(x, 1)).itemsIf IsArray(s) ThenCells(x + 1, 2).Resize(1, UBound(s) + 1) = sElseCells(x + 1, 2) = sEnd IfEnd IfNextSet d = NothingEnd Sub4，2级字典嵌套‘2013-2-21‘/thread-984445-1-1.htmlSub lqxs()Dim Arr, i&, x, yDim d, k, tSet d = CreateObject("Scripting.Dictionary")Arr = [a1].CurrentRegionFor 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) + 1Nextk = d.keyst = d.items:For i = 2 To UBound(Arr)If d.exists(Arr(i, 1)) Then Cells(i, 3) = d(Arr(i, 1)).CountNextEnd Sub‘2013-1-22‘/thread-974297-1-1.htmlSub lqxs()Dim Arr, i&, j&, n&, ttDim d, k, t, d1, x, y, k1Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Sheet2.ActivateArr = Sheet1.[a1].CurrentRegionFor i = 2 To UBound(Arr)x = Arr(i, 1)y = Left(Arr(i, 3), 1)d(x) = d(x) + 1If d1.Exists(x) = False Then Set d1(x) = CreateObject("Scripting.Dictionary") d1(x)(y) = d1(x)(y) + 1Nextk = d1.keyst = d1.items: n = 4: tt = 0For i = 0 To UBound(k)Cells(n, 1) = "小计"Cells(n, 2) = k(i)Cells(n, 3) = t(i).Counttt = tt + t(i).Countk1 = t(i).keysFor j = 0 To UBound(k1)n = n + 1Cells(n, 2) = k(i)Cells(n, 3) = k1(j)Cells(n, 4) = d1(k(i))(k1(j))Nextn = n + 1NextCells(3, 3) = ttEnd Sub5，3级字典嵌套‘2012-1-23‘/forum.php?mod=viewthread&tid=974963&page=2#pid6676611 Sub lqxs()Dim Arr, i&, Arr1, x$, n&, y&, Brr, r%, Brr1(), r2%, Brr2()Dim d, k, t, d1, k1, t1, k2, kk, a, b, c, cp$Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Sheet3.Activate[a2:d50000].ClearArr1 = Sheet1.[a1].CurrentRegionArr = Sheet2.[a1].CurrentRegionFor i = 2 To UBound(Arr)a = Arr(i, 4):b = Arr(i, 3)d(b) = aNextd.RemoveAllFor i = 2 To UBound(Arr1)a = Arr1(i, 4): c = Arr1(i, 7)b = Split(Arr1(i, 3), "]")(1)cp = a & "," & bIf a <> "" ThenIf d.Exists(a) = False Then Set d(a) = CreateObject("Scripting.Dictionary")d(a)(b) = bIf d1.Exists(cp) = False ThenSet d1(cp) = CreateObject("Scripting.Dictionary")End Ifd1(cp)(c) = d1(cp)(c) + 1End IfNextk = d.keys: k1 = d1.keyst = d.items: t1 = d1.items: n = 2For i = 0 To UBound(k)k2 = t(i).keysCells(n, 1) = k(i)For j = 0 To UBound(k2)Cells(n, 2) = k2(j)x = k(i) & "," & k2(j)kk = d1(x).keysFor y = 0 To UBound(kk)If d1(x)(kk(y)) <> 0 ThenCells(n, 3) = kk(y)Cells(n, 4) = d1(x)(kk(y))n = n + 1End IfNextNextNextBrr = [a1].CurrentRegionFor i = 2 To UBound(Brr)If Brr(i, 1) <> "" Thenr = r + 1ReDim Preserve Brr1(1 To r)Brr1(r) = iEnd IfIf Brr(i, 2) <> "" Thenr2 = r2 + 1ReDim Preserve Brr2(1 To r2)Brr2(r2) = iEnd IfNextFor i = 1 To rIf i <> r Thenjs = Brr1(i + 1) - 1Elsejs = UBound(Brr)End Ifks = Brr1(i)With Cells(ks, 1).Resize(js - ks + 1).MergeEnd WithNextFor i = 1 To r2If i <> r2 Thenjs = Brr2(i + 1) - 1Elsejs = UBound(Brr)End Ifks = Brr2(i)With Cells(ks, 2).Resize(js - ks + 1).MergeEnd WithNext[a1].CurrentRegion.Borders.LineStyle = 1 End Sub6，2级字典嵌套‘2013-2-6‘/thread-980784-1-1.htmlSub lqxs()Dim Arr, i&, j&Dim d, k, t, d1, k1, t1, n&Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Sheet2.ActivateArr = [a1].CurrentRegionFor j = 2 To UBound(Arr, 2)For i = 2 To UBound(Arr)d(Arr(1, j)) = d(Arr(1, j)) + 1If d1.Exists(Arr(1, j)) = False Then Set d1(Arr(1, j)) = CreateObject("Scripting.Dictionary")d1(Arr(1, j))(Arr(i, j)) = d1(Arr(1, j))(Arr(i, j)) + 1NextNextk = d.keys: t = d.itemsn = 40For i = 0 To UBound(k)k1 = d1(k(i)).keyst1 = d1(k(i)).itemsn = n + 1Cells(n, 1) = k(i)n = n + 1Cells(n, 1).Resize(d1(k(i)).Count, 1) = Application.Transpose(k1)Cells(n, 2).Resize(d1(k(i)).Count, 1) = Application.Transpose(t1)n = n + d1(k(i)).CountCells(n, 1) = "合计": Cells(n, 2) = t(i)NextEnd Sub7，字典的项为数组‘2013-2-8‘/thread-981240-1-1.htmlSub 数据3()Dim arrDim iRow&, i&, wbzb$'读取总表源数据wbzb = "总表"ThisWorkbook.ActivateWith Worksheets(wbzb)If Len(.[a4]) = 0 Then Exit Sub'高级筛选,去除重复值.Range("a3").CurrentRegion.AdvancedFilter xlFilterInPlace, , , TrueiRow = .Range("c" & Rows.Count).End(xlUp).RowIf iRow <= 3 Then Exit Sub '最后一行数据行低于第3行位置就退出arr = .Range("a3:j" & iRow)End With'arr2数组存储数据Dim dic As Object, arr2(), k&, j&'数据列对应关系，arrZos源列号，arrMpos目标列号Dim arrZPos, arrMPos, arrTemparrZPos = Array(4, 5, 6, 7, 8, 9, 10)arrMPos = Array(1, 2, 3, 4, 5, 10, 11)'以支行网点名字存入字典Set dic = CreateObject("Scripting.dictionary")For i = 2 To UBound(arr)If Not dic.exists(arr(i, 3)) ThenReDim arr2(1 To 11, 1 To 1)For j = LBound(arrZPos) To UBound(arrZPos)arr2(arrMPos(j), 1) = arr(i, arrZPos(j))Nextdic(arr(i, 3)) = Array(1, arr2) ' dic(arr(i, 3))(0)为存入个数，dic(arr(i, 3))(1)为数组ElsearrTemp = dic(arr(i, 3))k = arrTemp(0) + 1arr2 = arrTemp(1)ReDim Preserve arr2(1 To 11, 1 To k)For j = LBound(arrZPos) To UBound(arrZPos)arr2(arrMPos(j), k) = arr(i, arrZPos(j))Nextdic(arr(i, 3)) = Array(k, arr2)End IfNextOn Error Resume NextDim wb As WorkbookDim wbname$, Slash$wbname = "明细.xls"Slash = Application.PathSeparatorDim secAutomation As MsoAutomationSecuritySet wb = Workbooks(wbname)If Err.Number <> 0 ThenErr.ClearMsgBox ThisWorkbook.Path & Slash & wb'防止打开时运行宏secAutomation = Application.AutomationSecurityApplication.AutomationSecurity = msoAutomationSecurityForceDisableSet wb = Workbooks.Open(ThisWorkbook.Path & Slash & wbname)If Err.Number <> 0 ThenMsgBox "打开" & wb & " 出错"Err.ClearExit SubEnd IfEnd Ifwb.ActivateDim arrKey, wbZong$, keyitem, endrow2&, endrow&For Each keyitem In dic.keysWith Worksheets(keyitem)If Err.Number = 0 Then.Range("d:e").NumberFormatLocal = "@".Range("f:f").NumberFormatLocal = "G/通用格式"endrow = .Range("c" & Rows.Count).End(xlUp).Row = 3If endrow > 3 Then.Range("a4:j" & endrow).ClearContents.Range("a4:j" & endrow).Borders.LineStyle = xlNoneEnd Ifendrow = 4arr2 = WorksheetFunction.Transpose(dic(keyitem)(1))If dic(keyitem)(0) > 1 Then ‘只有1项时，赋值语句不同.Range("a" & endrow).Resize(UBound(arr2), 11) = arr2endrow2 = .Range("c" & Rows.Count).End(xlUp).Row.Range("f" & endrow).FormulaR1C1 = "=IF(COUNTIF(R4C[5]:RC11,RC[-1]&""*"")=1,""√"","""")".Range("f" & endrow & ":f" & endrow2).FillDownElse.Range("a" & endrow).Resize(1, 11) = arr2.Range("f4").FormulaR1C1 ="=IF(COUNTIF(R4C[5]:RC11,RC[-1]&""*"")=1,""√"","""")"End IfEnd IfErr.ClearEnd WithNextApplication.AutomationSecurity = msoAutomationSecurityByUIEnd Sub8，2级字典嵌套（数据有效性）‘2013-2-23‘/thread-985283-1-1.htmlPrivate Sub Worksheet_Change(ByVal Target As Range)If Target.Count > 1 Then Exit SubIf Target.Address <> "$K$2" And Target.Address <> "$M$2" Then Exit Sub Dim Arr, i&, x$, d, Brr, c%Set d = CreateObject("Scripting.Dictionary")Arr = [a1].CurrentRegionBrr = [a4].Resize(UBound(Arr) - 3, UBound(Arr, 2))For i = 5 To UBound(Arr, 2)x = Arr(1, i) & "|" & Arr(2, i)d(x) = iNextx = [k2].Value & "|" & [m2].Value[m4].Resize(UBound(Brr), 1).ClearContentsIf d.exists(x) Thenc = d(x)[m4].Resize(UBound(Brr), 1) = Application.Index(Brr, 0, c)End IfEnd SubPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Count > 1 Then Exit SubIf Target.Address <> "$K$2" And Target.Address <> "$M$2" Then Exit Sub Dim Arr, i&, x$, d, Brr, c%Set d = CreateObject("Scripting.Dictionary")Arr = [a1].CurrentRegionFor i = 5 To UBound(Arr, 2)x = Arr(1, i): y = Arr(2, i)If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary") d(x)(y) = d(x)(y) + 1Nextk = d.keysIf Target.Address = "$K$2" ThenWith Target.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, Formula1:=Join(d.keys, ",")End WithTarget.Offset(0, 2) = ""Elset = d(Target.Offset(0, -2).Value).keysWith Target.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, Formula1:=Join(t, ",")End WithEnd IfEnd Sub9，列表框4级数据有效性、多条件查询‘2013-3-3‘/thread-987829-1-1.htmlDim d As New Dictionary, Arr, Brr, k, tDim d1 As New DictionaryDim d2 As New DictionaryDim d3 As New DictionaryPrivate Sub ComboBox1_Change()ComboBox2.Clear: ComboBox2 = ""ComboBox3.Clear: ComboBox3 = ""ComboBox4.Clear: ComboBox4 = ""boBox2.List = d1(boBox1.Value).itemsEnd SubPrivate Sub ComboBox2_Change()If ComboBox2 = "" Then Exit SubComboBox3.ClearComboBox4.ClearboBox3.List = d2(boBox1.Value & boBox2.Value).items End SubPrivate Sub ComboBox3_Change()If ComboBox3 = "" Then Exit SubComboBox4.ClearboBox4.List = d3(boBox1.Value & boBox2.Value & boBox3.Value).itemsEnd SubPrivate Sub CommandButton1_Click()Dim i&, x$, y$, j&, aa[b7:g5000].ClearContentsArr = Sheet1.[a1].CurrentRegionIf boBox4 <> "" Thenx = boBox1.Text & boBox2.Text & boBox3.Text & boBox4.TextFor i = 2 To UBound(Arr)y = CStr(Arr(i, 1)) & Arr(i, 6) & Arr(i, 7) & Arr(i, 8)If x = y ThenIf Arr(i, 2) <> "" Then d(Arr(i, 2)) = d(Arr(i, 2)) & i & ","End IfNextCall yyy(2)[b6] = "销售人员"ElseIf boBox3 <> "" Thenx = boBox1.Text & boBox2.Text & boBox3.TextFor i = 2 To UBound(Arr)y = CStr(Arr(i, 1)) & Arr(i, 6) & Arr(i, 7)If x = y ThenIf Arr(i, 8) <> "" Then d(Arr(i, 8)) = d(Arr(i, 8)) & i & ","End IfNextCall yyy(8)[b6] = "小组"ElseIf boBox2 <> "" Thenx = boBox1.Text & boBox2.TextFor i = 2 To UBound(Arr)y = CStr(Arr(i, 1)) & Arr(i, 6)If x = y ThenIf Arr(i, 7) <> "" Then d(Arr(i, 7)) = d(Arr(i, 7)) & i & ","End IfNextCall yyy(7)[b6] = "区域"Elsex = boBox1.TextFor i = 2 To UBound(Arr)y = CStr(Arr(i, 1))If x = y ThenIf Arr(i, 6) <> "" Then d(Arr(i, 6)) = d(Arr(i, 6)) & i & ","End IfNextCall yyy(6)[b6] = "城市"End If[b7].Resize(UBound(Brr), 6) = Brrm = [b65536].End(xlUp).Row[f7].Formula = "=rc[-2]/rc[-3]"[g7].Formula = "=rc[-2]/rc[-4]"If m > 7 Then[f7:g7].AutoFill [f7:g7].Resize(m - 6, 2)End Ifd.RemoveAll: Erase BrrEnd SubSub yyy(c)k = d.keyst = d.itemsReDim Brr(1 To d.Count, 1 To 6)For i = 0 To UBound(k)t(i) = Left(t(i), Len(t(i)) - 1)If InStr(t(i), ",") Thenaa = Split(t(i), ",")For j = 0 To UBound(aa)Brr(i + 1, 1) = Arr(aa(j), c)Brr(i + 1, 2) = Brr(i + 1, 2) + Arr(aa(j), 3)Brr(i + 1, 3) = Brr(i + 1, 3) + Arr(aa(j), 9)Brr(i + 1, 4) = Brr(i + 1, 4) + Arr(aa(j), 10)NextElseBrr(i + 1, 1) = Arr(t(i), c)Brr(i + 1, 2) = Brr(i + 1, 2) + Arr(t(i), 3)Brr(i + 1, 3) = Brr(i + 1, 3) + Arr(t(i), 9)Brr(i + 1, 4) = Brr(i + 1, 4) + Arr(t(i), 10)End IfNextEnd SubPrivate Sub Worksheet_Activate()Dim i&, xx, yy, zz, aa, bb, cp, fl, xhOn Error Resume NextArr = Sheet1.[a1].CurrentRegionFor i = 2 To UBound(Arr)xx = Arr(i, 1) & ""yy = Arr(i, 6)zz = Arr(i, 7)aa = Arr(i, 8)cp = Arr(i, 1) & Arr(i, 6)fl = Arr(i, 1) & Arr(i, 6) & Arr(i, 7)If d1.Exists(xx) = False Then Set d1(xx) = New DictionaryIf yy <> "" Then d1(xx)(yy) = yyIf d2.Exists(cp) = False Then Set d2(cp) = New DictionaryIf zz <> "" Then d2(cp)(zz) = zzIf d3.Exists(fl) = False Then Set d3(fl) = New DictionaryIf aa <> "" Then d3(fl)(aa) = aaNextboBox1.List = d1.keysEnd Sub10，3级字典嵌套‘2013-3-8‘/forum.php?mod=viewthread&tid=989716&page=1&extra=#pid676777 9Sub lqxs()Dim Arr2, Arr3, Arr4, i&, x$, y$, j&, aa, bb, cp$Dim d, k, t, k1, t1, k2, t2, k3, t3, kk, tt, jj&, s&Dim Arr33, Arr5Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Sheet1.Activate[a2:l10].ClearContentsArr2 = Sheet2.[a1].CurrentRegionFor i = 2 To UBound(Arr2)d(Arr2(i, 1)) = d(Arr2(i, 1)) & i & ","Nextk = d.keyst = d.items: d.RemoveAllArr3 = Sheet3.[a1].CurrentRegionArr33 = Sheet3.[b1].Resize(UBound(Arr3), UBound(Arr3, 2))For i = 2 To UBound(Arr3)x = Arr3(i, 1): y = Arr3(i, 2)If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")d(x)(y) = d(x)(y) & i & ","Nextk1 = d.keyst1 = d.itemsArr4 = Sheet4.[a1].CurrentRegionArr5 = Sheet4.[b1].Resize(UBound(Arr4), UBound(Arr4, 2))For i = 2 To UBound(Arr4)x = Left(Arr4(i, 1), 1): y = Arr4(i, 1)cp = x & "," & yIf d1.exists(cp) = False Then Set d1(cp) = CreateObject("Scripting.Dictionary")d1(cp)(y) = d1(cp)(y) & i & ","Nextk2 = d1.keyst2 = d1.items: n = 2For i = 0 To UBound(k)t(i) = Left(t(i), Len(t(i)) - 1)Cells(n, 1).Resize(1, UBound(Arr2, 2)) = Application.Index(Arr2, t(i), 0)If d.exists(k(i)) Thenkk = t1(i).keys: tt = t1(i).itemsFor j = 0 To UBound(kk)cp = k(i) & "," & kk(j)tt(j) = Left(tt(j), Len(tt(j)) - 1)Cells(n, 5).Resize(1, UBound(Arr33, 2)) = Application.Index(Arr33, tt(j), 0)If d1.exists(cp) Thenk3 = t2(j).keyst3 = t2(j).itemsFor jj = 0 To UBound(k3)t3(jj) = Left(t3(jj), Len(t3(jj)) - 1)If InStr(t3(jj), ",") Thenbb = Split(t3(jj), ",")For s = 0 To UBound(bb)Cells(n, 9).Resize(1, UBound(Arr5, 2)) = Application.Index(Arr5, bb(s), 0)n = n + 1NextElseCells(n, 9).Resize(1, UBound(Arr5, 2)) = Application.Index(Arr5, t3(jj), 0)n = n + 1End IfNextElsen = n + 1End IfNextNextEnd Sub11，2级字典嵌套汇总‘2013-3-9‘/thread-990101-1-1.htmlSub lqxs()Dim Arr, i&, x$, y$Dim d, k, d1Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Sheet3.ActivateArr = Sheet1.[a1].CurrentRegionFor i = 2 To UBound(Arr)x = Arr(i, 5): y = Arr(i, 1)If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")d(x)(y) = d(x)(y) + Arr(i, 8)Nextk = d.keysArr2 = Sheet2.[a1].CurrentRegionFor i = 2 To UBound(Arr2)x = Arr2(i, 2): y = Left(Arr2(i, 1), 7)If d1.exists(x) = False Then Set d1(x) = CreateObject("Scripting.Dictionary")d1(x)(y) = d1(x)(y) + Arr2(i, 3)Next[a2].Resize(d.Count) = Application.Transpose(k)For i = 0 To UBound(k)Cells(i + 2, 2) = d(k(i))(CStr([b1].Value))Cells(i + 2, 3) = d(k(i))(CStr([c1].Value))Cells(i + 2, 4) = Cells(i + 2, 2) + Cells(i + 2, 3) - d1(k(i))(CStr([b1].Value)) - d1(k(i))(CStr([c1].Value))NextEnd Sub12，2级字典嵌套（数据有效性）‘/thread-922132-1-1.htmlPrivate Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Count > 1 Then Exit SubIf (Target.Column <> 4 And Target.Column <> 6) Or Target.Row < 2 Then Exit Sub Dim t, Arr, dDim i&, x$, Brr, y$Set d = CreateObject("Scripting.Dictionary")Arr = Sheet10.[f1].CurrentRegionFor 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) = yNextIf Target.Column = 4 ThenWith Target.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, Formula1:=Join(d.keys, ",")End WithTarget.Offset(0, 2) = ""Elsex = Target.Offset(0, -2).ValueIf d.exists(x) Thent = d(x).keysWith Target.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, Formula1:=IIf(UBound(t) <> -1, Join(t, ","), t) End WithElseTarget = ""End IfEnd IfEnd Sub13，2级字典嵌套（成绩提取）‘2013-3-24‘/thread-995893-1-1.htmlSub lqxs()Dim Arr, i&, Arr1, x$, y$, funm$, myPath$, myName$, BrrDim d, k, t, wb As Workbook, a, b, aa, j&, zh, ps, txt$, mx1, mx2Application.ScreenUpdating = FalseSet d = CreateObject("Scripting.Dictionary")Sheet1.ActivateArr1 = [a1].CurrentRegion[a1].CurrentRegion.ClearCommentsSet wb = ThisWorkbookfunm = myPath = ThisWorkbook.Path & "\"myName = Dir(myPath & "*.xlsx")Do While myName <> "" And myName <> funmWith GetObject(myPath & myName)Arr = .Sheets(1).Range("a1").CurrentRegion.Close FalseFor i = 1 To UBound(Arr, 2)If Arr(1, i) = "学号" Then c1 = iIf Arr(1, i) = "课程名称" Then c2 = i: Exit ForNextFor i = 2 To UBound(Arr)x = Arr(i, c1): y = Arr(i, c2)If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")d(x)(y) = d(x)(y) & Arr(i, c2 + 1) & "," & Arr(i, c2 + 2) & "|"NextEnd WithmyName = DirLoopk = d.keys: t = d.itemsFor i = 9 To UBound(Arr1) - 1x = Arr1(i, 2)If d.exists(x) ThenFor j = 6 To UBound(Arr1, 2) Step 2y = Arr1(7, j)If d(x).exists(y) Thena = d(x)(y)a = Left(a, Len(a) - 1)If InStr(a, "|") Thenaa = Split(a, "|")mx1 = 0: mx2 = 0: txt = ""For ii = 0 To UBound(aa)txt = txt & ii + 1 & "," & aa(ii) & vbCrLfb = Split(aa(ii), ",")zh = Val(b(0)): ps = V al(b(1))If zh > mx1 Then mx1 = zhIf ps > mx2 Then mx2 = psNextCells(i, j).AddComment Text:=txtArr1(i, j) = mx1: Arr1(i, j + 1) = mx2Elseaa = Split(a, ",")Arr1(i, j) = aa(0): Arr1(i, j + 1) = aa(1)End IfEnd IfNextEnd IfNextColumns("b:b").NumberFormatLocal = "@"[a1].CurrentRegion = Arr1Application.ScreenUpdating = TrueEnd Sub14，多条件查询‘2013-5-19‘/thread-1018683-1-1.htmlSub lqxs()Dim Arr, i&, d, k, t, d1, Brr, j&, Arr1Dim x$, y, z$, a$, b$, c$Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Sheet1.Activate[b5:p6].ClearContents[b5:p6].Borders.LineStyle = xlNoneArr1 = [a1].CurrentRegionArr = Sheet2.[a1].CurrentRegionFor i = 3 To UBound(Arr, 2)d1(Arr(2, i)) = iNextk1 = d1.keys[b5].Resize(1, d1.Count) = k1[b5].Resize(2, d1.Count).Borders.LineStyle = 1ReDim Brr(1 To d1.Count)For j = 3 To UBound(Arr, 2)For i = 3 To UBound(Arr)x = Arr(i, 1): z = Arr(i, 2): y = Arr(2, j)a = x & "|" & z:b = x & "|" & y:c = z & "|" & yIf d.exists(a) = False Then Set d(a) = CreateObject("Scripting.Dictionary")d(a)(y) = d(a)(y) + Arr(i, j)d(b) = d(b) + Arr(i, j)d(c) = d(c) + Arr(i, j)NextNextk = d.keys: t = d.itemsFor j = 2 To UBound(Arr1, 2)If Arr1(1, j) <> "" ThenIf Arr1(2, j) <> "" Thena = Arr1(1, j) & "|" & Arr1(2, j)For i = 0 To UBound(k1)tt = d(a)(k1(i))Brr(i + 1) = Brr(i + 1) + d(a)(k1(i))NextElseFor i = 0 To UBound(k1)b = Arr1(1, j) & "|" & k1(i)Brr(i + 1) = Brr(i + 1) + d(b)NextEnd IfElseIf Arr1(2, j) <> "" ThenFor i = 0 To UBound(k1)c = Arr1(2, j) & "|" & k1(i)Brr(i + 1) = Brr(i + 1) + d(c)NextEnd IfEnd IfNext[b6].Resize(1, d1.Count) = BrrEnd Sub15，2级字典嵌套（分表）‘/thread-1026658-1-1.html‘Split Data0613.xlsmSub lqxs()Dim Arr, i&, x$, y$, Sht As WorksheetDim d, k, t, k1, t1, Myr&, rng As RangeSet d = CreateObject("Scripting.Dictionary")Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseFor Each Sht In SheetsIf <> "Data" And <> "模板" Then Sht.Delete NextSheet1.ActivateArr = [a1].CurrentRegionFor i = 2 To UBound(Arr)x = Arr(i, 2): y = Trim(Arr(i, 3))If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")d(x)(y) = d(x)(y) + 1Nextk = d.keys: t = d.itemsFor i = 0 To UBound(k)Sheets("模板").Copy after:=Sheets(Sheets.Count)Set Sht = ActiveSheetWith Sht.Name = k(i)k1 = t(i).keyst1 = t(i).itemsSet rng = .[a31:d38].[a31] = k1(0).[d32] = t1(0)For j = 1 To UBound(k1)Myr = .[c65536].End(xlUp).Row + 1rng.Copy .Cells(Myr, 1).Cells(Myr, 1) = k1(j).Cells(Myr + 1, 4) = t1(j)NextEnd WithNextApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub16，中国式排名（D列）‘/thread-1103691-1-1.htmlSub lqxs()Dim Arr, i&, x, y$, j&, aa, Brr, Crr, cDim d, k, t, d1, k1, t1, kk, ttSet d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Sheet1.Activate[d2:e5000].ClearContentsArr = [a1].CurrentRegionFor 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) & i & ","Nextk = d.keys: t = d.itemsFor i = 0 To UBound(k)kk = t(i).keys: tt = t(i).itemsFor ii = 0 To UBound(kk)tt(ii) = Left(tt(ii), Len(tt(ii)) - 1): n = 0: n1 = 0If InStr(tt(ii), ",") Thenaa = Split(tt(ii), ",")ReDim Brr(UBound(aa))ReDim Crr(UBound(aa))For j = 0 To UBound(aa)Brr(j) = Arr(aa(j), 3)NextFor j = 0 To UBound(Brr)d1(Brr(j)) = d1(Brr(j)) & aa(j) & ","Nextk1 = d1.keys: t1 = d1.itemsd1.RemoveAllFor j = 0 To UBound(k1)t1(j) = Left(t1(j), Len(t1(j)) - 1)If InStr(t1(j), ",") Thena = Split(t1(j), ",")n = n + 1: n1 = n1 + 1For jj = 0 To UBound(a)Arr(a(jj), 4) = nArr(a(jj), 5) = n1Nextn1 = n1 + UBound(a)Elsen = n + 1Arr(t1(j), 4) = nn1 = n1 + 1Arr(t1(j), 5) = n1End IfNextElseArr(tt(ii), 4) = 1Arr(tt(ii), 5) = 1End IfNextNext[a1].CurrentRegion = ArrEnd Sub17，多级字典嵌套by:lee1892'===============================================' 字典实现的多级单元格下拉示例' By Lee1892 @ ExcelHome 2011.05.06'-----------------------------------------------' 此示例中：' Sheet1 为需要实现级联的表单' Sheet2 为存放级联内容的表单' 涉及到的事件包括：' Workbook 的Open 事件' Sheet1 的Change 事件' Sheet2 的Change 事件'-----------------------------------------------' 可以实现的功能：' 1 根据级联内容表单的内容自动生成动态级联下拉单，' 没有级联层数的限制' 2 可以随时更新级联内容，包括级联的层数和内容。