VBA新手学习笔记之：二级下拉菜单(字典嵌套法)教学内容

合集下载

EXCEL VBA 常见字典用法集锦及代码详解(全)之欧阳语创编

常见字典用法集锦及代码详解前言凡是上过学校的人都使用过字典，从新华字典、成语词典，到英汉字典以及各种各样数不胜数的专业字典，字典是上学必备的、经常查阅的工具书。

有了它们，我们可以很方便的通过查找某个关键字，进而查到这个关键字的种种解释，非常快捷实用。

凡是上过EH论坛的想学习VBA里面字典用法的，几乎都看过研究过northwolves狼版主、oobird版主的有关字典的精华贴和经典代码。

我也是从这里接触到和学习到字典的，在此，对他们表示深深的谢意，同时也对很多把字典用得出神入化的高手们致敬，从他们那里我们也学到了很多，也得到了提高。

字典对象只有4个属性和6个方法，相对其它的对象要简洁得多，而且容易理解使用方便，功能强大，运行速度非常快，效率极高。

深受大家的喜爱。

本文希望通过对一些字典应用的典型实例的代码的详细解释来给初次接触字典和想要进一步了解字典用法的朋友提供一点备查的参考资料，希望大家能喜欢。

给代码注释估计是大家都怕做的，因为往往是出力不讨好的，稍不留神或者自己确实理解得不对，还会贻误他人。

所以下面的这些注释如果有不对或者不妥当的地方，请大家跟帖时指正批评，及时改正。

字典的简介字典（Dictionary）对象是微软Windows 脚本语言中的一个很有用的对象。

附带提一下，有名的正则表达式（RegExp）对象和能方便处理驱动器、文件夹和文件的（FileSystemObject）对象也是微软Windows 脚本语言中的一份子。

字典对象相当于一种联合数组，它是由具有唯一性的关键字（Key）和它的项（Item）联合组成。

就好像一本字典书一样，是由很多生字和对它们对应的注解所组成。

比如字典的“典”字的解释是这样的：“典”字就是具有唯一性的关键字，后面的解释就是它的项，和“典”字联合组成一对数据。

常用关键字英汉对照：Dictionary 字典Key 关键字Item 项，或者译为条目字典对象的方法有6个：Add方法、Keys 方法、Items方法、Exists方法、Remove方法、RemoveAll方法。

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 可以随时更新级联内容，包括级联的层数和内容。

VBA学习笔记

EXCEL之VBA学习笔记：磊时间：2015年9目录第一章 VBA根底知识3第二章工作簿以及工作表的操作9第三章：单元格区域操作14第四章：事件程序:36第五章：VBA数组43第一章 VBA根底知识1：代码帮助： F12：代码换行：下划线+空格+回车3：.常用代码操作excel中的对象〔1〕、工作簿〔Workbooks〕Workbooks〔N〕第N个工作簿Workbooks ("工作簿名")ActiveWorkbook 活动工作簿ThisWorkBook 代码所在工作簿〔2〕、工作表〔Worksheets〕Sheets(N) 第N个工作表Sheets("工作表名")SheetN 第N个工作表ActiveSheet 活动工作表worksheets 与 Sheets的区别〔3〕、单元格〔cells〕Range ("单元格地址")Cells(行号,列号)[A1]单元格简写Activecell 活动单元格Selection 当前被选取的区域4：常量与变量〔1.〕常量：常量是定义了之后就不做变化了。

常量定义格式：Const 常量名= 常量表达式〔2〕.变量:在定义之后还能再次赋值变量定义格式：Dim 变量 As 变量类型5：数据类型〔1.〕VBA中的常见数据类型：类型注释简写占用存Integer 整型 % 2ByteSingle 单精度 ! 4ByteDouble 双精度 # 8ByteLong 长整型 & 4ByteString 字符型 $ 定长或变长( 变长字符串最多可包含大约20 亿 ( 2^31)个字符。

定长字符串可包含 1 到大约 64K ( 2^16 ) 个字符。

)Currency 货币型 8Byte6:if条件语句1.单行形式1〔If...Then〕If 条件判断 Then 条件成立结果注意在单行形式中，按照 If...Then 判断的结果也可以执行多条语句。

关于下拉菜单，你知道的和不知道的，都在这里了「超全收录」

关于下拉菜单，你知道的和不知道的，都在这里了「超全收录」一、下拉菜单的基础（三种制作方式）1. 数据有效性制作下拉菜单2. 表单控件之组合框制作下拉菜单3. ActiveX控件之组合框制作下拉菜单二、二级下拉菜单制作三、三级下拉菜单制作四、下拉菜单的特殊操作1. 多列数据如何设置数据有效性2. 如何制作关键字提醒的下拉菜单3. 如何制作越选越少的下拉菜单五、Word中下拉菜单的制作下拉菜单的基础一、数据有效性制作下拉菜单依次找到【数据】→【数据有效性】→【数据有效性(V)…】 → 【设置】序列 → 【设置】来源数据有效性制作下拉菜单来源有以下四种：①直接引用单元格区域（限制其仅能引用同一工作表中同一列或者同一行的连续区域）；②引用公式（公式必须是引用某个连续的列（行）区域，支持数组，但不支持内存数组）；③使用定义名称（就是把第②项的公式定义成名称，然后引用这个名称，可实现跨表引用数据）；④直接输入序列（例如：输入『1,2,3,4,5,6,7』，注：此处只能使用半角逗号分隔，区分大小写）。

小技巧：在直接输入序列的时候，如何在下拉列表中做一个空格选项呢？如果是手动输入序列来源，则用全角状态下的空格；如果是用公式，公式引用的时候多引用一行空白内容即可。

下拉列表中增加空白选项二、表单控件之组合框制作下拉菜单依次找到【开发工具】→【插入】→【表单控件】→【组合框】→工作表中画一个组合框 → 设置控件格式 → 【控制】数据来源区域 → 【控制】单元格链接【控制】下拉显示项数表单控件制作下拉菜单注意：使用表单控件的组合框，选择菜单中的某一项后，单元格中得到的内容并非所选择的内容，而是所选择的内容在数据列中所处的位置。

（此法常用于制作动态的图表）三、ActiveX控件之组合框制作下拉菜单依次找到【开发工具】→【插入】→【ActiveX控件】→【组合框】 → 工作表中画一个组合框 → 右键选择【属性】 →【ListFillRange】数据来源区域 → 【LinkedCell |】单元格链接 → 【ListRows】下拉显示项数 → 退出设计模式ActiveX控件制作下拉菜单用ActiveX控件制作简单的下拉菜单，还可以设置其他的属性，比图控件的大小、位置、风格、字体、颜色等。

ExcelVBA字典

ExcelVBA字典Option Explicit'1 什么是VBA字典？'字典（dictionary）是一个储存数据的小仓库。

共有两列。

'第一列叫key , 不允许有重复的元素。

'第二列是item,每一个key对应一个item，本列允许为重复'Key item'A 10'B 20'C 30'Z 10'2 即然有数组，为什么还要学字典？'原因:提速，具体表现在'1) A列只能装入非重复的元素，利用这个特点可以很方便的提取不重复的值'2) 每一个key对应一个唯一的item，只要指点key的值，就可以马上返回其对应的item，利用字典可以实现快速的查找'3 字典有什么局限？'字典只有两列，如果要处理多列的数据，还需要通过字符串的组合和拆分来实现。

'字典调用会耗费一定时间，如果是数据量不大，字典的优势就无法体现出来。

'4 字典在哪里？如何创建字典？'字典是由scrrun.dll链接库提供的，要调用字典有两种方法'第一种方法：直接创建法'Set d = CreateObject("scripting.dictionary")'第二种方法：引用法'工具-引用-浏览-找到scrrun.dll-确定Option ExplicitSub t1()Dim D As New DictionaryDim x As IntegerFor x = 2 To 4D.Add Cells(x, 1).Value, Cells(x, 2).ValueNext xMsgBox D.Keys(0)MsgBox D.Keys(1)MsgBox D.Keys(2)MsgBox D.Items(0)'StopEnd Sub'2 读取数据Sub t2()' Dim DDim D As New DictionaryDim arrDim x As Integer' Set D = CreateObject("scripting.dictionary")For x = 2 To 4D.Add Cells(x, 1).Value, Cells(x, 2).ValueNext xMsgBox D("李四")MsgBox D.Keys(2)Range("d1").Resize(D.Count) = Application.Transpose(D.Keys) Range("e1").Resize(D.Count) = Application.Transpose(D.Items)arr = D.ItemsEnd SubSub t3()Dim D As New DictionaryDim x As IntegerFor x = 2 To 4D.Add Cells(x, 1).Value, Cells(x, 2).Value Next xD("李四") = 78MsgBox D("李四")D("赵六") = 100MsgBox D("赵六")End Sub'4 删除数据Sub t4()Dim D As New DictionaryDim x As IntegerFor x = 2 To 4D(Cells(x, 1).Value) = Cells(x, 2).Value Next xD.Remove "李四"' MsgBox d.Exists("李四")D.RemoveAllMsgBox D.CountEnd Sub'区分大小写Dim D As New DictionaryDim xFor x = 1 To 5D(Cells(x, 1).Value) = ""Next xStopEnd Subub 求和问题()Dim arr, D As Object, arDim i As Integer, j As ByteSet D = CreateObject("scripting.dictionary")arr = Sheet2.Range("a1").CurrentRegion '选定区域装入数组Dim t$For i = 1 To UBound(arr) '循环从数组第1行到数组的最后一行t = arr(i, 1) & "|" & arr(i, 2)If D.Exists(t) ThenD(t) = t & "|" & (--Split(D(t), "|")(2) + arr(i, 3)) '如果有相应的key,则提取对应item的的销售额与现有的相加，再组合后存入字典ElseD(t) = t & "|" & arr(i, 3) '如果没有相应的Key，则存入"日期｜名称｜销售额"End IfNext iReDim arr(1 To D.Count, 1 To 3)ar = D.ItemsFor i = 1 To UBound(ar) + 1For j = 1 To 3arr(i, j) = Split(ar(i - 1), "|")(j - 1)Next jNext iSheet3.Range("a1").CurrentRegion.ClearContentsSheet3.Range("a1").Resize(UBound(arr), 3) = arrEnd SubOption ExplicitSub 多表双向查找()Dim d As New DictionaryDim x, yDim arrFor x = 3 To 5arr = Sheets(x).Range("a2").Resize(Sheets(x).Range("a65536").End(xlU p).Row - 1, 2) For y = 1 To UBound(arr)d(arr(y, 1)) = arr(y, 2)d(arr(y, 2)) = arr(y, 1)Next yNext xMsgBox d("C1")MsgBox d("吴情")End SubOption ExplicitSub 汇总()Dim d As New DictionaryDim arr, xarr = Range("a2:b10")For x = 1 To UBound(arr)d(arr(x, 1)) = d(arr(x, 1)) + arr(x, 2) 'key对应的item的值在原来的基础上加新的Next xRange("d2").Resize(d.Count) = Application.Transpose(d.Keys) Range("e2").Resize(d.Count) = Application.Transpose(d.Items)End SubOption ExplicitSub 提取不重复的产品()Dim d As New DictionaryDim arr, xarr = Range("a2:a12")For x = 1 To UBound(arr)d(arr(x, 1)) = ""Next xRange("c2").Resize(d.Count) = Application.Transpose(d.Keys) End Sub。

在excel中如何做二级下拉菜单和三级下拉菜单.doc

在excel中如何做二级下拉菜单和三级下拉
菜单
1，如何创建一级下拉菜单。

步骤：选择需要创建下拉菜单的区域--- 数据--- 数据验证--- 设置--- 允许（序列）--- 来源--- 选择下拉菜单的内容---确定。

2，如何创建二级下拉菜单。

步骤：选择一级二级内容---公式---根据所选内容创建---只在首行打钩---确定---选择创建二级菜单的区域---数据---数据验证--- 设置---允许（序列）---来源（=INDIRECT(A7)）---确定。

3，如何创建三级下拉菜单。

步骤：选择二级三级内容---公式---根据所选内容创建---只在首行打钩---确定---选择创建三级菜单的区域---数据---数据验证--- 设置---允许（序列）---来源（=INDIRECT(B7)）---确定。

ExcelVBA字典实现窗体二级下拉菜单

ExcelVBA字典实现窗体二级下拉菜单ExcelVBA字典实现窗体二级下拉菜单问题提出:选择确定ComboBox1中的数值后，ComboBox2的下拉列表自动引用ComboBox1中数值对应的列的内容。

如何能做到我现在想在加一重判断：就是判断ComboBox2中的数值，如果是原来ComboBox1对应列中已有的值，就直接向下进行，如果原来ComboBox1对应列中没有该值，自动添加到该列最下一个非空行之后再向下执行。

字典的引用:窗体代码如下:Public Arr, Dic As NewDictionary'声明为公共变量,引用“Microsoft Scripting Runtime”Private Sub UserForm_Initialize() '窗体初始化事件DimBrrArr =Sheet1.Range("A1").CurrentRegion.Value 'A1单元格已用区域For i = 1 ToUBound(Arr,2)'循环标题，并添加到字典If Not Dic.Exists(Arr(1, i))Then'字典中不存在关键字Dic.Add Arr(1, i), Dic.Count +1'添加关键字,Item为索引End IfNextBrr =Dic.KeysboBox1.Clear'清除列表框1条目For i = 0 ToUBound(Brr) -1'列表框1添加条目boBox1.AddItem Brr(i) NextEnd SubPrivate Sub ComboBox1_DropButtonClick() '列表框1下拉事件DimBrrIfboBox1.Text = "" Then ExitSub'如果列表框1为空，就退出过程boBox2.Clear'清空列表框2条目IfDic.Exists(boBox1.Text) Then '如果列表框的关键字,在字典中有记录Brr = Application.WorksheetFunction.Index(Arr, 0,Dic(boBox1.Text)) '用Index函数取出整列数据For i = 2 To UBound(Brr,1)'列表框2添加条目boBox2.AddItem Brr(i,1)'列表框2添加条目NextEnd IfEnd SubPrivate Sub CommandButton1_Click() '按钮1单击事件IfboBox1.Text = "" Or boBox2.Text = ""Then ExitSub'如果列表框1,2为空，就退出过程Dim Brr,CrrBrr =Application.WorksheetFunction.Index(Arr, 0,Dic(boBox1.Text))'用Index函数取出整列数据Crr =VBA.Filter(Application.Transpose(Brr),boBox2.Text,True)'取出匹配列表框2的值IfUBound(Crr) = -1 Then'如果有列表框2的值,数组不会为-1,'如果列表框2中没有此关键字,往原数据添加此关键字Sheet1.Cells(Rows.Count,Dic(boBox1.Text)).End(xlUp).Offset(1).Value = boBox2.TextEnd IfSheet1.Cells(Rows.Count, 10).End(xlUp).Offset(1).Value =boBox2.Text'+ boBox1.Text '把数据写入单元格boBox1.Text = "": boBox2.Text = ""'列表框1，2显示为空白boBox1.Clear:boBox2.Clear'清空列表框1，2的条目CallUserForm_Initialize'初始化窗体，为下一次录入数据准备End Sub效果图:更多分享请关注微信号微信号：Excel335081548 或: 雪山飞狐Excel 喜欢本文，请点击右上角，分享本文。

VBA嵌套字典的递归输出（序列化）

VBA嵌套字典的递归输出（序列化）6VBA嵌套字典的递归输出（序列化）作者：AntoniotheFuture关键词：VBA，字典，Dictionary，嵌套，递归，序列化开发平台：VBE平台版本上限：未知平台版本下限：未知开发语言：VBA简介：用递归的方法将一个VBA的嵌套字典对象全部输出到文本框内。

最近笔者的工作中使用到了VBA的Dictionary（字典）对象，这种对象是一种键值对对象，表现形式为：key:item ，其中Key是不可重复的，item也可以为另外一个字典，多个字典嵌套所形成的对象可以让我很方便地操作一个类，我在这一个对象内完成大部分的动作，极大地简化了我的代码。

要创建这样的对象，只需要像下面这样做就行了：1.Dim AllDic as object2.Dim PeopleDic as object3.Dim HousesDic as object4.Dim HouseDic as object5.Dim RommDic as object6.set AllDic = CreateObject('Scripting.Dictionary')7.set PeopleDic = CreateObject('Scripting.Dictionary')8.set HousesDic = CreateObject('Scripting.Dictionary')9.set HouseDic = CreateObject('Scripting.Dictionary')10.set RommDic = CreateObject('Scripting.Dictionary')11.12.RommDic.add 1,'客厅'13.RommDic.add 2,'主卧'15.HouseDic.add 'Addr','中山路3号'16.HouseDic.add 'Price','120万'17.HouseDic.add 'Rooms',RommDic18.19.HousesDic.add 1,HouseDic20.21.RommDic.removeall22.HouseDic.removeall23.24.RommDic.add 1,'客厅'25.RommDic.add 2,'主卧'26.RommDic.add 3,'阳台'27.HouseDic.add 'Addr','西安路58号'28.HouseDic.add 'Price','90万'29.HouseDic.add 'Rooms',RommDic30.HousesDic.add 2,HouseDic31.32.PeopleDic.add 'Name','王明'33.PeopleDic.add 'BirthDate','1990-01-01'34.PeopleDic.add 'Horses',HousesDic35.36.AllDic.add 1,PeopleDic37.38.RommDic.removeall39.HouseDic.removeall40.HousesDic.removeall41.PeopleDic.removeall42.43.RommDic.add 1,'客厅'45.RommDic.add 3,'次卧1'46.HouseDic.add 'Addr','北京路159号'47.HouseDic.add 'Price','145万'48.HouseDic.add 'Rooms',RommDic49.HousesDic.add 1,HouseDic50.PeopleDic.add 'Name','李红'51.PeopleDic.add 'BirthDate','1980-10-01'52.PeopleDic.add 'Horses',HousesDic53.54.AllDic.add 2,PeopleDic这样我们创建了AllDic这样一个嵌套的字典，他的实际内容是这样的：1.AllDic:2.1::'王明'4.BirthDate:'1990-01-01'5.Horses:6.1:7.Addr:'中山路3号'8.Price:'120万'9.Rooms:10.1:'客厅'11.2:'主卧'12.3,'厨房'13.2:14.Addr:'西安路58号'15.Price:'90万'16.Rooms:17.1:'客厅'18.2:'主卧'19.3,'阳台'20.2::'李红'22.BirthDate:'1980-10-01'23.Horses:24.1:25.Addr:'北京路159号'26.Price:'145万'27.Rooms:28.1:'客厅'29.2:'主卧'30.3,'次卧1'31.32.33.34.35.这是一个四层的字典，第二层是人，第三层是房子，第四层是房间，需要引用里面的信息时，只需要像这样就行了：第一个人第二套房子的地址：AllDic(1)('Horses')(2)('Addr')第二个人的生日：AllDic(2)('BirthDate')这种结构是不是似曾相识呢？对的，他就像Json。

VBA新手学习笔记之：二级下拉菜单(字典嵌套法)教学内容

V B A新手学习笔记之：二级下拉菜单(字典嵌套法)VBA新手学习笔记之：二级下拉菜单（字典嵌套法）如下效果图：今天这个效果所涉及的新增知识点有：1. 模块级变量的定义2. 事件程序3. 字典嵌套4. Join函数下面我们逐一来解读下这四个知识点：1.先看看什么是事件之前我们执行Excel程序都需要手动画一个按钮，然后将对应的过程指定给这个按钮，当我们需要程序运行的时候，就发送一个命令（点一下按钮）给这个程序，程序接收命令后，会按照程序的逻辑进行运行。

而事件程序是不需要手工指定按钮，而是当我们在操作Excel的时候有些动作会自动被ExcelVBA所识别，VBA内部已经自行内置了有关此事件的过程名，我们在对应的过程中写需要执行操作的代码，当Excel的某个动作发生的时候，会自动触发执行所写的程序。

这个案例所用到的事件程序有两个：第一：单元格选区发生变化的时候：当需要填写省份的那一列的单元格选区发生变化时，需要添加去重后的省份的下拉菜单操作方法：对准需要达到效果的工作表名的位置右键——查看代码——进入工作表的代码编辑区——选择worksheet——会自动弹出（单元格选区发生变化时要执行的过程）——在该过程中写所需要的代码即可Private SubWorksheet_SelectionChange(ByVal Target As Range)End Sub第二：单元格的值发生变化的时候：当省份填写完毕后，则需要将对应省份的城市添加到城市单元格的下拉菜单，如果省份单元格没有填、则城市下拉菜单跟着消失。

操作方法：前面的操作与第一点都是一样的，调出代码窗口后——选择worksheet——在事件下拉框中选择Change事件——会自动生成（单元格值发生变化时要执行的过程）Private Sub Worksheet_Change(ByValTarget As Range)End Sub2.因为今天的两个程序中都需要使用同一个字典来做数据有效性的下拉菜单，所以用了一个字典对象的模块级变量dicSF,所谓模块级变量即在同一个模块内所有程序都能使用的变量；这里涉及到变量的作用域的问题，大家可以百度搜索下什么叫变量的作用域。

Excel之VBA常用功能应用篇：Excel下拉列表的操作方法

Excel之VBA常用功能应用篇：Excel下拉列表的操作方法本节介绍一下ControlFormat对象，严格来说这个对象是对应于Excel中的ListBox对象的一些属性和方法，为什么不以ListBox来返回，就不太清楚了。

总之，要对Excel表中的ListBox对象操作就这么做就行了。

那么，如何得到ControlFormat对象呢？用下面的方法：dim xCF as ObjectSet xCF=Shapes(i).ControlsFormat对象xCF就是一个ControlFormat对象，其中i代表了此Shape 的Index值。

这就有点不可想象了，Shape是Excel表绘图层中的对象，例如自选图形、任意多边形、OLE 对象或图片，此处就代表了一个OLE对象，即ListBox。

有点乱，但要了解一下Shape对象，如下图所示，有按钮对象，下拉列表和文本框对象，都属于Shapes对象合集。

可以使用Shape对象的ContrlFormat来返回ContrlFormat对象。

当我们得到这个ContrlFormat对象之后，就可以对下拉列表框进行各种添加删除操作了。

ContrlFormat对象有四个方法：Additem、List、RemoveAllitems、Removeitem懂基本英语就基本明白这四种方法的功能了，这里不做过多介绍，具体可参考下面的代码进行对号。

更加重要的是ContrlFormat的属性，一共有17个，属性就是用一些固定的参数来进行设置，可以使下拉列表框更加符合要求，目的很简单。

下面，用实例来证明一下我们通过代码如何实现对下拉列表的添加、修改、删除等等操作。

添加列表框Private Sub AddListBox()DelListbox '删除除列表框Dim xlobj As Object'添加列表框Set xlobj =Me.Shapes.AddFormControl(xlListBox,Range("E3").Left, Range("E3").T op, 200,350)Dim xFormat As ObjectSet xFormat = xlobj.ControlFormat '返回列表对象xFormat.RemoveAllItems '清除列表内容xFormat.ListFillRange =Range("C4:C20").Address'设置列表区域Set xFormat = NothingSet xlobj = NothingEnd Sub返回列表值Private Sub ShowListValue()Dim xShape As ShapeFor Each xShape In Me.ShapesIf xShape.Type = 8 ThenMsgBoxxShape.ControlFormat.List(xShape.ControlFormat.ListIndex)End IfNext xShapeEnd Sub给列表框添加列表Private Sub AddListItems()Dim xShape As ShapeFor Each xShape In Me.Shapes'遍历ShapesIf xShape.Type = 8 Then'如果是列表xShape.ControlFormat.RemoveAllItems'清除所有列表值For i = 4 To 7xShape.ControlFormat.AddItemRange("B" & i).Value'添加列表Next iEnd IfNext xShapeEnd Sub如上代码，根据ContrlFormat的四个方法和属性可实现所有对列表框的添加删除修改功能。

vb二级知识点

第1章Visual Basic程序开发环境【考点一】Visual Basic的特点和版本一、Visual Basic的特点Visual Basic是一种可视化的、面向对象和采用事件驱动方式的结构化高级程序设计语言，可用于开发Windows环境下的各类应用程序。

总的来看，Visual Basic有以下主要特点：1.可视化编程2.面向对象的程序设计3.结构化程序设计语言4.事件驱动编程机制5.访问数据库6.动态数据交换(DDE)7.对象的链接与嵌入(OLE)8.动态链接库(DLL)9.建立用户自己的ActiveX控件10.建立ActiveX文档11.Internet组件下载12.枚举类型二、Visual Basic的版本Visual Basic 6.0包括3种版本，分别为学习版、专业版和企业版。

(1)学习版：Visual Basic的基础版本，可用来开发Windows应用程序。

该版本包括所有的内部控件(标准控件)、网络(Grid)控件、Tab对象以及数据绑定控件。

(2)专业版：该版本为专业编程人员提供了一整套用于软件开发、功能完备的工具。

它包括学习版的全部功能，同时包括ActiveX控件、Internet控件、Crystal Report Writer和报表控件。

(3)企业版：可供专业编程人员开发功能强大的组内分布式应用程序。

该版本包括专业版的全部功能，同时具有自动化管理器、部件管理器、数据库管理工具、Microsoft Visual SourceSafe面向工程版的控制系统等。

【考点二】Visual Basic的启动与退出开机并进入中文Windows后，可以用多种方法启动Visual Basic。

第一种方法：使用“开始”菜单中的“程序”命令。

操作如下：(1)单击Windows环境下的“开始”按钮，弹出一个菜单，把光标移到“程序”命令上，将弹出下一个级联菜单；(2)把光标移到“Microsoft Visual Basic 6.0中文版”，弹出下一个级联菜单，即Visual Basic 6.0程序组；(3)单击“Microsoft Visual Basic 6.0中文版”，即可进入Visual Basic 6.0编程环境。

(完整版)VBA字典用法集锦及案例代码详解

VBA字典用法集锦及案例代码详解dadaVBA字典用法集锦及案例代码详解前言凡是上过学校的人都使用过字典，从新华字典、成语词典，到英汉字典以及各种各样数不胜数的专业字典，字典是上学必备的、经常查阅的工具书。

有了它们，我们可以很方便的通过查找某个关键字，进而查到这个关键字的种种解释，非常快捷实用。

凡是上过EH论坛的想学习VBA里面字典用法的，几乎都看过研究过northwolves狼版主、oobird版主的有关字典的精华贴和经典代码。

字典对象只有4个属性和6个方法，相对其它的对象要简洁得多，而且容易理解使用方便，功能强大，运行速度非常快，效率极高。

深受大家的喜爱。

给代码注释估计是大家都怕做的，因为往往是出力不讨好的，稍不留神或者自己确实理解得不对，还会贻误他人。

所以下面的这些注释如果有不对或者不妥当的地方，请大家跟帖时指正批评，及时改正。

字典的简介字典（Dictionary）对象是微软Windows脚本语言中的一个很有用的对象。

附带提一下，有名的正则表达式（RegExp）对象和能方便处理驱动器、文件夹和文件的（FileSystemObject）对象也是微软Windows脚本语言中的一份子。

字典对象相当于一种联合数组，它是由具有唯一性的关键字（Key）和它的项（Item）联合组成。

就好像一本字典书一样，是由很多生字和对它们对应的注解所组成。

比如字典的“典”字的解释是这样的：“典”字就是具有唯一性的关键字，后面的解释就是它的项，和“典”字联合组成一对数据。

常用关键字英汉对照：2字典的简介Dictionary 字典Key 关键字Item 项，或者译为条目字典对象的方法有6个：Add方法、Keys方法、Items方法、Exists方法、Remove方法、RemoveAll方法。

EXCEL VBA 常见字典用法集锦及代码详解(全)之欧阳科创编

有了它们，我们可以很方便的通过查找某个关键字，进而查到这个关键字的种种解释，非常快捷实用。

凡是上过EH论坛的想学习VBA里面字典用法的，几乎都看过研究过northwolves狼版主、oobird版主的有关字典的精华贴和经典代码。

字典对象只有4个属性和6个方法，相对其它的对象要简洁得多，而且容易理解使用方便，功能强大，运行速度非常快，效率极高。

深受大家的喜爱。

给代码注释估计是大家都怕做的，因为往往是出力不讨好的，稍不留神或者自己确实理解得不对，还会贻误他人。

所以下面的这些注释如果有不对或者不妥当的地方，请大家跟帖时指正批评，及时改正。

字典的简介字典（Dictionary）对象是微软Windows脚本语言中的一个很有用的对象。

附带提一下，有名的正则表达式（RegExp）对象和能方便处理驱动器、文件夹和文件的（FileSystemObject）对象也是微软Windows脚本语言中的一份子。

字典对象相当于一种联合数组，它是由具有唯一性的关键字（Key）和它的项（Item）联合组成。

就好像一本字典书一样，是由很多生字和对它们对应的注解所组成。

比如字典的“典”字的解释是这样的：“典”字就是具有唯一性的关键字，后面的解释就是它的项，和“典”字联合组成一对数据。

常用关键字英汉对照：Dictionary 字典Key 关键字Item 项，或者译为条目字典对象的方法有6个：Add方法、Keys方法、Items方法、Exists方法、Remove方法、RemoveAll方法。

Excel初学者对于VBA字典法的理解

Excel初学者对于VBA字典法的理解本帖最后由 f8b1987 于 2012-6-8 12:34 编辑引用: 在引用工作表名称把单元格写入数组的话，定义数组不要使用dim arr()这种形式，使用dim arr即可。

接触了VBA字典法一段时间，虽然没有什么大的提升，总算对字典法有个初步的理解。

想当初，刚学的时候，可是问了很多幼稚的问题{:soso_e106:}。

对于字典法的含义解释，当然有EH VBA版主蓝桥玄霜的帖子：版主的帖子说得挺不错的。

但是，对于像我这种VBA学习水平不高且初学字典法的人，有很多地方还是有点难理解的。

在这里，我只作为一个菜鸟的理解，用菜鸟的语言对字典法进行基础解释。

我们看下面的代码：1.Sub 字典简要解释()2.Dim i As Integer, j As Integer, dic As Object, arr, brr3.'定义i、j，定义字典对象dic，定义动态数组arr、brr4.5.Set dic = CreateObject('scripting.dictionary')6.'固定用法，意为创建字典对象,这里的dic是变量，并非要求用dic。

7.brr = Sheet2.Range('a1').CurrentRegion8.'单元格区域装入数组，查看范围可以选择A1单元格，按下CTRL+*即可选定该范围9.arr = Sheet1.Range('a1').CurrentRegion10.11.12.For i = 2 To UBound(brr)13.dic(brr(i, 1)) = brr(i, 2)14.'字典(KEY)=item，意思是把brr(i,1)的值循环写入字典的key，并把brr(i,2)作为字典的item15.'dic锁的集合体，有很多锁。

好比是：锁头（钥匙）=打开锁的车子16.17.'Key = brr(i, 1)18.19.'理论上一条不同的钥匙只能打开一把锁，你能打开宝马的锁还是打开摩托车的锁，就取决于你的钥匙。

ExcelVBA字典实现窗体二级下拉菜单

EXCEL VBA 常见字典用法集锦及代码详解(全)之欧阳道创编

有了它们，我们可以很方便的通过查找某个关键字，进而查到这个关键字的种种解释，非常快捷实用。

凡是上过EH论坛的想学习VBA里面字典用法的，几乎都看过研究过northwolves 狼版主、oobird版主的有关字典的精华贴和经典代码。

字典对象只有4个属性和6个方法，相对其它的对象要简洁得多，而且容易理解使用方便，功能强大，运行速度非常快，效率极高。

深受大家的喜爱。

给代码注释估计是大家都怕做的，因为往往是出力不讨好的，稍不留神或者自己确实理解得不对，还会贻误他人。

所以下面的这些注释如果有不对或者不妥当的地方，请大家跟帖时指正批评，及时改正。

字典的简介字典（Dictionary）对象是微软Windows 脚本语言中的一个很有用的对象。

附带提一下，有名的正则表达式（RegExp）对象和能方便处理驱动器、文件夹和文件的（FileSystemObject）对象也是微软Windows 脚本语言中的一份子。

字典对象相当于一种联合数组，它是由具有唯一性的关键字（Key）和它的项（Item）联合组成。

就好像一本字典书一样，是由很多生字和对它们对应的注解所组成。

比如字典的“典”字的解释是这样的：“典”字就是具有唯一性的关键字，后面的解释就是它的项，和“典”字联合组成一对数据。

常用关键字英汉对照：Dictionary 字典Key 关键字Item 项，或者译为条目字典对象的方法有6个：Add方法、Keys方法、Items方法、Exists方法、Remove方法、RemoveAll方法。

Excel二级下拉菜单共19页

这样，就在E2单元格生成了一级下拉菜单（省）。
11.同样的方法，选中F2单元格，设置数据有效性，选择【序列】，【来源处】输入公式：=INDIRECT($E2)。然后点击【确定】按钮。
谢谢你的阅读
❖ 知识就是财富 ❖ 丰富你的人生
71、既然我已经踏上这条道路，那么，任何东西都不应妨碍我沿着这条路走下去。——康德 72、家庭成为快乐的种子在外也不致成为障碍物但在旅行之际却是夜间的伴侣。——西塞罗 73、坚持意志伟大的事业需要始终不渝的精神。——伏尔泰 74、路漫漫其修道远，吾将上下而求索。——屈原 75、内外相应，言行相称。——韩非
4.选择【公式】-【根据所选Fra bibliotek容创建】。5.由于1级菜单“省”在第一行，因此选择【首行】为名称，然后点击【确定】按钮。
6.操作完毕后，在名称管理器中就可以看到定义的名称了。
7.选中第一行的内容（也就是一级菜单的所有内容），在名称框中输入“sheng”，然后按回车（按回车键），这样就定义了一个名称。
假设用”A,B,C”分别代表三个不用的省份
而“A1,A2”“B1,B2…””C1,C2…”则代表与之相对应的城市。
1,将1级菜单和2级下拉菜单内容如下图所示排列。
2.选中原始表的所有数据（包括多余的空白单元格），按 F5或者Ctrl+G调出定位对话框。选择左下角的【定位条件】。
3.如下图，选则【常量】，并点击【确定】按钮。这样，所有的非空单元格被选中。
Excel二级下拉菜单
21、静念园林好，人间良可辞。 22、步步寻往迹，有处特依依。 23、望云惭高鸟，临木愧游鱼。 24、结庐在人境，而无车马喧；问君何能尔？心远地自偏。 25、人生归有道，衣食固其端。

VBA学习笔记

EXCEL之VBA 学习笔记姓名：刘磊时间：2015年9目录第一章VBA基础知识 (3)第二章工作簿以及工作表的操作 (9)第三章：单元格区域操作 (14)第四章：事件程序: (36)第五章：VBA数组 (43)第一章VBA基础知识1：代码帮助：F12：代码换行：下划线+空格+回车3：.常用代码操作excel中的对象（1）、工作簿（Workbooks）Workbooks（N）第N个工作簿Workbooks ("工作簿名")ActiveWorkbook 活动工作簿ThisWorkBook 代码所在工作簿（2）、工作表（Worksheets）Sheets(N) 第N个工作表Sheets("工作表名")SheetN 第N个工作表ActiveSheet 活动工作表worksheets 与Sheets的区别（3）、单元格（cells）Range ("单元格地址")Cells(行号,列号)[A1]单元格简写Activecell 活动单元格Selection 当前被选取的区域4：常量与变量（1.）常量：常量是定义了之后就不做变化了。

常量定义格式：Const 常量名= 常量表达式（2）.变量:在定义之后还能再次赋值变量定义格式：Dim 变量As 变量类型5：数据类型（1.）VBA中的常见数据类型：类型注释简写占用内存Integer 整型% 2ByteSingle 单精度! 4ByteDouble 双精度# 8ByteLong 长整型& 4ByteString 字符型$ 定长或变长( 变长字符串最多可包含大约20 亿( 2^31)个字符。

定长字符串可包含1 到大约64K ( 2^16 ) 个字符。

)Currency 货币型@ 8Byte6:if条件语句1.单行形式1（If...Then）If 条件判断Then 条件成立结果注意在单行形式中，按照If...Then 判断的结果也可以执行多条语句。

1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。

V B A新手学习笔记之：二级下拉菜单(字
典嵌套法)
VBA新手学习笔记之：二级下拉菜单（字典嵌套法）
如下效果图：
今天这个效果所涉及的新增知识点有：1. 模块级变量的定义2. 事件程序3. 字典嵌套4. Join函数
下面我们逐一来解读下这四个知识点：
1.先看看什么是事件之前我们执行Excel程序都需要手动画一个按钮，然后将对应的过程指定给这个按钮，当我们需要程序运行的时候，就发送一个命令（点一下按钮）给这个程序，程序接收命令后，会按照程序的逻辑进行运行。

这个案例所用到的事件程序有两个：第一：单元格选区发生变化的时候：当需要填写省份的那一列的单元格选区发生变化时，需要添加去重后的省份的下拉菜单操作方法：对准需要达到效果的工作表名的位置右键——查看代码——进入工作表的代码编辑区——选择worksheet——会自动
弹出（单元格选区发生变化时要执行的过程）——在该过程中写所需要的代码即可
Private SubWorksheet_SelectionChange(ByVal Target As Range)
End Sub
第二：单元格的值发生变化的时候：当省份填写完毕后，则需要将对应省份的城市添加到城市单元格的下拉菜单，如果省份单元格没有填、则城市下拉菜单跟着消失。

操作方法：前面的操作与第一点都是一样的，调出代码窗口后——选择worksheet——在事件下拉框中选择Change事件——会自动生成（单元格值发生变化时要执行的过程）Private Sub Worksheet_Change(ByValTarget As Range)
End Sub
2.因为今天的两个程序中都需要使用同一个字典来做数据有效性的下拉菜单，所以用了一个字典对象的模块级变量dicSF,所谓模块级变量即在同一个模块内所有程序都能使用的变量；这里涉及到变量的作用域的问题，大家可以百度搜索下什么叫变量的作用域。

3.字典嵌套的运用，因为我们要通过不同的省份分别对应找到其对应的城市，显然这是一个字典无法完成的事情，因为我们有很多个省份，多个省份下又又多个城市，所以我们在省份字典dicSF中每存入一个省份，那么就将这个省份
作为一个新的字典的名称再创建一个字典，在这个字典下将城市再存入省份这个字典的Keys里字典嵌套大家不要想得太复杂，我们只要将省份字典的keys看成是你定义的一个新的字典名称，就很容易理解了就拿案例来说：字典嵌套的核心代码见下For i = 2 To UBound(arr) If Not dicSF.Exists(arr(i,1)) Then '创建对应省份的字典 Set dicSF(arr(i, 1)) =CreateObject('scripting.dictionary') End If '在该省份的字典内添加所属城市 dicSF(arr(i,1))(arr(i, 2)) = ''Next i代码解读：如果字典dicSF中没有对应的省份，比如现在I循环到2，那么省份就是云南，第一个循环，云南还没有存到dicSF中，那么 NotdicSF.Exists(arr(i, 1))的结果就是True，就执行下面的这个创建字典的操作Set dicSF(arr(i, 1)) =CreateObject('scripting.dictionary')，我们把代码分解出来，dicSF是我们定义的一个字典名称；同理：Set
dicSF(arr(i, 1))也可以看成我们定义的一个字典的名称，如果i=2,那么这里的dicSF(arr(i, 1))实际上就是dicSF（云南），那么在这个字典里添加对应城市的代码 dicSF(arr(i, 1))(arr(i, 2)) =''就可以看成dicSF（云南）（思茅市）=“”，也就是说“思茅市”是dicSF（云南）的第一个key。

循环完之后，所有的省份就都创建了一个字典并将其下属的城市都存进其keys中了。

4.join函数是将一个数组以给定的分割符组合成一个长字符串，数据有效性种序列来源值的格式要求将每个城市以逗
号分割开，我们知道，字典的keys和Items都是一个以0开
始的一维数组，在选择来源的时候我们不能直接将数组给它，所以就用到Join函数来连接数组的每个元素了。

With Target.Validation .Delete .AddType:=xlValidateList,Al ertStyle:=xlValidAlertStop,Operator:=_ xlBetween, Formula1:=Join(dicSF.Keys, ',')End With
最后附上两段完整的代码：Option Explicit '要求变量声明
Dim dicSF As Object '定义一个模块级变量用来存去重之后
的省份'单元格的值发生变化时要做的事Private Sub Worksheet_Change(ByVal Target As Range) Dim strSF As String With Target If .Column <> 6 Then Exit Sub If .Count <> 1 Then Exit Sub strSF = .Value
'下面是通过'数据有效性'录制宏得到的代码
With .Offset(0, 1).Validation .Delete If strSF
<> '' Then .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=Join(dicSF(strSF).Keys, ',')
Else .Add Type:=xlValidateInputOnly,
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween End If End With End
WithEnd Sub
'单元格选区发生变化时要做的事Private Sub
Worksheet_SelectionChange(ByVal Target As Range) Dim
arr, i As Integer If Target.Column <> 6 Then Exit Sub
If Target.Row > 1 Then '清空选中单元格对应城市的
单元格的内容 Target.Offset(0, 1).Value = '' Set dicSF
= CreateObject('scripting.dictionary') arr =
Range('A1').CurrentRegion.Value For i = 2 To UBound(arr) '如果字典里没有保存该省份 If Not dicSF.Exists(arr(i,
1)) Then '创建对应省份的字典 Set
dicSF(arr(i, 1)) = CreateObject('scripting.dictionary') End
If '在该省份的字典内添加所属城市 dicSF(arr(i,
1))(arr(i, 2)) = '' Next i '添加数据有效性 With
Target.Validation .Delete .Add
Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=
_ xlBetween, Formula1:=Join(dicSF.Keys, ',') End
With End IfEnd Sub
好了，今天分享完毕，各位早点休息。