|
一、字典常识 1、字典对象相当于一种联合数组，它是由具有唯一性的关键字（Key）和它的项（Item）联合组成。（Key相当于一个容器，这个容器是唯一的、是独一无二的，Item相当于容器中放的物品） 2、VBA字典有6个方法Add , Keys, Items, Exists, Remove, RemoveAll。 3、VBA字典有4个属性Count , Key, Item, CompareMode。 4、方法属性解析（附代码） Option Explicit '强制对模块内所有变量进行声明 Sub 字典练习() '创建字典d Dim d As Object Set d = CreateObject('Scripting.Dictionary') Dim x, arr, brr, t '定义t为可变型变量。 t = Timer '把系统时间赋给变量t，Timer为系统时间。 '把记录增加到字典中去，向字典中增加3个容器a、b、c，里面分别装入11，10，9。 d.Add 'a', 11'第1个容器名字叫a，里面装的是11这个数字 d.Add 'b', 10 d.Add 'c', 9‘（见图2） d('b') = 7 '修改字典中记录只能这样写，用上面的方法会报错，或者用下面的方法 d.Item('b') = 6 '检查记录是否在字典中，在返回True，不在返回False（见图7） Range('a1') = d.Exists('b') '替换key，即更换容器（见图8） d.Key('a') = 'e' '所有key和所有item其实分别是一个数组（见图9） arr = d.keys brr = d.items '输出字典中的Key值（见图3） Range('a1') = d('a') Range('a2') = d.Item('b') Range('a3') = d.Item('c') '统计字典中记录条数（见图4） x = d.Count '把记录移除出字典 d.Remove ('b') '移除指定记录（见图5） d.RemoveAll '移除所有记录（见图6） MsgBox '运行结束，用时：' & Timer - t & '秒!' '弹个消息框提示一下代码运行是否结束，可以放置多行。 End Sub 图1，空字典，里面记录的条数为0。 图2，经过往字典中增加记录，现在已经有3条记录了，名字分别是a、b、c。 图3，通过对b项的两次修改，Key已改成了6。 图4，统计字典中记录条数 图5，移除字典中指定记录 图6，移除字典中的所有记录 图7，检查记录是否在字典中，在返回True，不在返回False。 图8，替换Key，即更换容器。 图9，Key、Item其实就是一个数组。Key相当于一个容器，这个容器是唯一的、是独一无二的，Item相当于容器中放的物品。 二、字典运用实例 1、任务：提取下表总表中的所有乡镇名称，要求一个乡镇名称只能提取一次。 2、代码 Option Explicit '强制对模块内所有变量进行声明 Sub 提取不重复值() '创建字典d Dim d As Object Set d = CreateObject('Scripting.Dictionary') Dim arr, brr(), x, y, t '定义t为可变型变量。 Application.DisplayAlerts = False '在程序执行过程中使出现的警告框不显示 Application.ScreenUpdating = False '关闭屏幕刷新 'On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息。能不用尽量不要用，否则可能会显示错误的结果。 t = Timer '把系统时间赋给变量t，Timer为系统时间。 '清空结果表中的数据 Sheets('结果').Cells.Clear '把总表数据写入数组 arr = Sheets('总表').Range('a3:p' & Sheets('总表').Range('c65536').End(xlUp).Row) '把数组中的乡镇列(第3列)读入字典 For x = 1 To UBound(arr, 1) If Not d.Exists(arr(x, 3)) Then '判断乡镇是否在字典中，如果不在则执行下面的语句 y = y 1 '如果该乡镇不在字典中，则把该乡镇增加到字典中，用数字序号来存放 d(arr(x, 3)) = y ReDim Preserve brr(1 To 2, 1 To y) '重新定义数组brr，只有两行，第1行放容器，第2行放容器中装的物品 brr(1, y) = y '把容器写到数组的第1行，即乡镇序号 brr(2, y) = arr(x, 3) '把物品写到数组的第2行，即乡镇名称 End If Next x '把得到的新数组的值写入到【结果】表中,Resize为定义需要扩展的高度和宽度，Application.WorksheetFunction.Transpose为调用转置功能Transpose Sheets('结果').Range('a1').Resize(UBound(brr, 2), UBound(brr, 1)) = Application.WorksheetFunction.Transpose(brr) MsgBox '运行结束，用时：' & Timer - t & '秒!' '弹个消息框提示一下代码运行是否结束，可以放置多行。 Application.DisplayAlerts = True '在程序执行过程中使出现的警告框显示 Application.ScreenUpdating = True '打开屏幕刷新 End Sub 如果同时要把不同的村也提取出来，我们可以把上面代码中的arr(x, 3)全部替换为arr(x, 3)&arr(x, 4)，大家自己去试吧。 3、结果
|
|
|
