常见字典用法集锦及代码详解

搁浅2008

收藏指定火

liuguansky

期待续贴。[em03]

wbzxz

蓝桥老师现在放出这个东东出来，真是及时雨啊，我保证每天顶一次，不然这个好帖子沉下去。

hhzjxss

谢谢蓝兄分享，下载收藏再学习之！

hhaa999

通俗易懂，解释的很明白，学习字典的好东西，支持

zhj1978

好东西，谢谢

蓝桥玄霜

实例8  2级动态数据有效性问题

一、问题的提出：

A列是源名称，中间有空格，B列为各个源名称对应的数目不同的代号，C列是目标名称来源于源名称，要求在C列设置不重复的、没有空格的数据有效性供选择；同时D列目标代号，要求随着C列选择的目标名称的不同，提供对应的代号供选择，是为第2级数据有效性。

 

代码执行前如图实例8-1所示。

 

图 实例8-1示例

 

二、代码：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Count > 1 Then Exit Sub

If Target.Column <> 4 And Target.Column <> 3 Then Exit Sub

Dim d, i&, Myr&, Arr, r%, Arr1(), cp$, ks&, js&, j&

Set d = CreateObject("Scripting.Dictionary")

Myr =[b65536].End(xlUp).Row

Arr = Range("a2:b" & Myr)

If Target.Column = 3 Then

    For i = 1 To UBound(Arr)

        If Arr(i, 1) <> "" Then

            d(Arr(i, 1)) = ""

        End If

    Next

    With Target.Validation

        .Delete

        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _

        Operator:=xlBetween, Formula1:=Join(d.keys, ",")

    End With

    Target.Offset(0, 1) = ""

ElseIf Target.Column = 4 And Target.Offset(0, -1) <> "" Then

    For i = 1 To UBound(Arr)

        If Arr(i, 1) <> "" Then

            r = r + 1

            ReDim Preserve Arr1(1 To r)

            Arr1(r) = i

        End If

    Next i

    For i = 1 To r

        If Arr(Arr1(i), 1) = Target.Offset(0, -1).Text Then

            If i <> r Then

                js = Arr1(i + 1) - 1

            Else

                js = Myr - 1

            End If

            ks = Arr1(i)

            For j = ks To js

                cp = cp & Arr(j, 2) & ","

            Next

        End If

    Next i

    cp = Left(cp, Len(cp) - 1)

    With Target.Validation

        .Delete

        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _

        Operator:=xlBetween, Formula1:=cp

    End With

    Target = Split(cp, ",")(0)

End If

Set d = Nothing

End Sub

三、代码详解

1、Private Sub Worksheet_SelectionChange(ByVal Target As Range) ：本例用的是工作表选择变化事件，只要鼠标点击单元格都会激活这个事件。Private 可译为私有的，限制了这段代码只能在指定的工作表里有效。参数Target声明为单元格区域对象，有了关键字ByVal，说明可以按值传递参数。

2、If Target.Count > 1 Then Exit Sub  ：由于是鼠标点击单元格都会激活这个事件,所以最好要作一些限制，使得你能避免点击了不需要激活事件的地方而激活本事件产生错误。本句是如果目标单元格的数目大于1就退出本过程。这样当你点选了多个单元格的时候，过程运行了这句代码就会结束过程了。

3、If Target.Column <> 4 And Target.Column <> 3 Then Exit Sub  ：再加一个限制，如果目标单元格的列不是3列（C列）也不是4列（D列）的话就退出过程。

4、接着的四句代码分别是声明变量、创建字典对象、B列最后一个非空单元格的行数以及把单元格区域的值赋给数组变量等等与前面的实例相同。请注意这里选择了B列求最后一个非空单元格的行数，是因为A列各数据之间有空格，如果选择A列，就会遗漏一些数据。

5、If Target.Column = 3 Then ：现在分两种情况判断，如果点击的目标单元格是C列的，那么执行下面的代码。

6、If Arr(i, 1) <> "" Then ：在数组Arr之间逐一循环，如果A列数组的值不等于空，就作为关键字加入字典d。这样就排除了空值进入字典。

7、With Target.Validation ：这里使用了With语句，With语句为我们提供了十分简便的对象引用手段。使用它有3个优点：可以减少代码的输入量、增加代码的可读性。改善代码的执行效率。在End With之前的语句都是对目标单元格的有效性对象的各个属性进行设置。

8、.Delete ：先删除该单元格的数据有效性。注意Delete前有个小圆点，在小圆点之前就省略了Target.Validation，即减少了代码的输入量。这个小圆点不能遗漏，否则会出错。

9、.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _

Operator:=xlBetween, Formula1:=Join(d.keys, ",") ：Add是有效性对象的方法，向指定区域内添加数据有效性检验。参数Type是数据有效性类型，当类型等于xlValidateList时，后面的公式1参数Formula1 必须包含以逗号分隔的取值列表。参数AlertStyle是出错警告样式，这里是停止样式；参数Operator是数据有效性运算符，有大于、小于、大于或等于、小于或等于、介于、不介于、等于、不等于等等，这里取介于；公式1参数Formula1的值用了VBA函数Join，把字典的关键字用逗号分隔后连接起来赋给公式1参数。这样，目标单元格那的数据有效性中就没有重复值了。

10、Target.Offset(0, 1) = "" ：给目标单元格设置了数据有效性以后，把它同行D列单元格的值清除。这是为了确保D列的值只与C列的目标名称相对应。

11、ElseIf Target.Column = 4 And Target.Offset(0, -1) <> "" Then ：否则如果目标单元格是D列的，并且同行C列单元格不是空的情况下，执行这下面的代码。Offset属性的详解可见前面实例6的第2条解释。

12、For i = 1 To UBound(Arr) ：在数组Arr之间逐一循环。

13、If Arr(i, 1) <> "" Then ：如果A列数组的值不等于空，就执行下面的代码。

14、r = r + 1 ：变量r累加。

15、ReDim Preserve Arr1(1 To r) ：重新声明动态数组的大小，Preserve是关键字，当改变原有数组最末维的大小时，使用此关键字可以保持数组中原来的数据。这句是改变动态数组大小的最常用语句，不能忘记Preserve关键字。

16、Arr1(r) = i ：把关键字在数组Arr中行的位置赋给新的动态数组Arr1(r)。这个循环可求得A列每一个源名称所在的行的位置。

17、For i = 1 To r ：上面的循环求得了一共有r个源名称，逐一循环。

18、If Arr(Arr1(i), 1) = Target.Offset(0, -1).Text Then ：如果C列的目标名称等于源名称时执行下面的代码。

19、If i <> r Then ：如果i不等于r时执行下面的代码。

20、js = Arr1(i + 1) – 1 ：把下一个源名称所在的行数-1以后赋给变量js，这样来求得每一个源名称的开始和结束的位置。

21、js = Myr – 1 ：否则就是最后一行－1的只赋给变量js（最后一个源名称在数组中的位置）。

22、ks = Arr1(i) ：把数组的值赋给变量ks：得到每一个源名称的起始位置。

23、For j = ks To js ：从每一个源名称的起始位置到结束位置逐一循环。

24、cp = cp & Arr(j, 2) & "," ：把相应的代号与逗号连接起来组成的字符串赋给变量cp。

25、cp = Left(cp, Len(cp) - 1) ：用了两个VBA函数Left和Len把去掉末位的逗号。

26、With 语句解释同上，为D列单元格设置了第2级数据有效性。

27、Target = Split(cp, ",")(0) ：按照问题的第3个要求，在目标名称确定后，在目标代号相应位置自动生成目标名称的第一个代号。因为Split得到的是一个以0为下界的一维函数，所以它的第一个元素就用(0)来表示。

 

代码执行后如图实例8-2所示。

图 实例8-2示例

 附件见8楼。

走进EXCEL

通俗易懂，解释的很明白

帅

[em02][em02][em02]收藏，谢谢分享

蓝桥玄霜

实例9  字典取行数，数组重新赋值

一、问题的提出：

要求编写一段代码，求得B列不重复的名字，其相应的A列和D列分别用" "连起来，而相应的E列F列的数值分别相加汇总。

代码执行前如图实例9-1所示。

图 实例9-1示例

 

二、代码：

Sub yy()  'by:Zamyi

Dim d As New Dictionary, R

Dim k, i&, j&

R = Sheet1.UsedRange

k = 1

For i = 2 To UBound(R)

    R(i, 2) = Replace(Replace(R(i, 2), "（", "("), "）", ")")

    If d.Exists(R(i, 2)) Then

        R(d(R(i, 2)), 1) = R(d(R(i, 2)), 1) & " " & R(i, 1)

        R(d(R(i, 2)), 4) = R(d(R(i, 2)), 4) & " " & R(i, 4)

        R(d(R(i, 2)), 5) = Val(R(d(R(i, 2)), 5)) + R(i, 5)

        R(d(R(i, 2)), 6) = Val(R(d(R(i, 2)), 6)) + R(i, 6)

    Else

        k = k + 1

        d(R(i, 2)) = i

        For j = 1 To UBound(R, 2)

            R(k, j) = R(i, j)

        Next

  End If

Next

With Sheet2

    .Cells.ClearContents

    .Cells.Borders.LineStyle = xlNone

    .[a1:F1].Resize(d.Count + 1) = R

    .[a1:F1].Resize(d.Count + 1).Borders.LineStyle = 1

End With

Set d = Nothing

End Sub

三、代码详解

1、R = Sheet1.UsedRange ：把表1的已经使用了的单元格区域的值赋给变量R。

2、k = 1 ：变量k赋初值1。

3、For i = 2 To UBound(R)  ：由于第一行是表头，所以从第2行开始循环。

4、R(i, 2) = Replace(Replace(R(i, 2), "（", "("), "）", ")") ：由于源数据中用了不统一的括号，所以加了这句把里面中文括号统一替换为英文括号。这句用了两次VBA函数Replace，一次替换前半个，另一次替换后半个。Replace函数有6个参数，详细请查阅VBA帮助文件。如果在这里解释，篇幅太长了，也冲淡了字典的主题。

5、If d.Exists(R(i, 2)) Then ：这句用字典的Exists方法进行判断，如果字典中存在R(i, 2)这个关键字，那么执行下面的代码。

6、这里先解释，Else如果上面的判断不成立，即字典中不存在这个关键字时，要执行下面的代码。

7、k = k + 1 ：变量k+1以后再赋给k。

8、d(R(i, 2)) = i ：公司名字作为关键字，对应的项是它所在的行，把它们加入字典d。

9、For j = 1 To UBound(R, 2) ：知道了这个关键字所在的行，下面这个循环就是重新给数组同一行的各个元素赋值。UBound(R, 2)是用VBA函数Ubound求得数组R的第2维的最大上界。比如本例R数组第1维的最大上界是8，有8行数据；而第2维的最大上界是6，有6列数据。本循环j就是从第1列到第6列依次循环。

10、R(k, j) = R(i, j) ：把i行j列的数组元素赋给k行j列的R数组元素。

11、R(d(R(i, 2)), 1) = R(d(R(i, 2)), 1) & " " & R(i, 1) ：再回来说如果R(i, 2)这个关键字存在，则执行这条代码。在这之前，这关键字已经加入字典了，它的同一行的各个数组元素也重新赋过值了，所以根据问题的要求，把A列的数据用" "连起来再赋给A列这个数组元素。

12、R(d(R(i, 2)), 4) = R(d(R(i, 2)), 4) & " " & R(i, 4) ：D列数据同上。

13、R(d(R(i, 2)), 5) = Val(R(d(R(i, 2)), 5)) + R(i, 5) ：E 列数据要相加，这里用了VBA函数Val，把E列数组元素转为数值以后相加汇总。下句类同。

14、With Sheet2 ：With语句，前面介绍过的。

15、.Cells.ClearContents ：清空表2所有的数据。Cells是工作表对象的属性，指工作表所有的单元格；ClearContents是它的方法，清除里面的公式、数据，但是保留格式设置。

16、.Cells.Borders.LineStyle = xlNone ：清除表2所有的边框。Borders是Cells的属性，意思是单元格的边框；LineStyle是边框的属性，为边框的线型，它有直线、虚线、点划线等等，这里取值xlNone是清除边框。

17、.[a1:F1].Resize(d.Count + 1) = R ：把数组R的值赋给表2A1单元格开始的区域。

18、.[a1:F1].Resize(d.Count + 1).Borders.LineStyle = 1 ：给这些单元格添加边框，线型为直线。

 

代码执行后如图实例9-2所示。

 

rDEalQPS.rar (22.38 KB, 下载次数: 302)

2010-10-24 20:02 上传

点击文件名下载附件
常见字典用法集锦及代码详解
doc 文件请到1楼下载。