VBA字典用法集锦及代码详解 - 图文

实例7 字典法排序

[c3].Resize(UBound(rng), 4) = arr End Sub

三、代码详解

1、Dim d As Object, rng, i%, j%, arr :声明各个变量。

2、Set d = CreateObject(\:创建字典对象d。

3、rng = Range(\& [a65536].End(xlUp).Row) :把A列到F列的单元格区域的值赋给变量rng。

4、ReDim arr(1 To UBound(rng), 1 To 4) :根据数组rng的大小重新声明动态数组变量的大小,这里是按最大数量来声明,可避免因声明得小了而导致代码出错。 5、For i = 1 To UBound(rng) :在rng数组中逐一循环。

6、d(CStr(rng(i, 1))) = i :把A列的股票代码的值用VBA转换函数CStr转换成字符串以后作为关键字,因为如果不作处理有时候遇到00开始的数据,可能会失去前面的0。股票代码在数组中的行位置i作为关键字对应的项,一起加入字典d。 7、For j = 3 To 5 Step 2 :前面的循环得到了整个字典,下面这两个循环用来与字典中的关键字比对而重新排位。Step 2是循环的步长,j=3执行以后,j=3+2=5,从而跳过j=4了。呵呵,这是For…Next循环结构的基础知识,说多了。

8、For i = 1 To Cells(65536, j).End(xlUp).Row – 2 :因为C列和E列的最后一个非空单元格的位置不一样,所以用了Cells(65536, j).End(xlUp).Row在循环中分别得到这两列的最后一个非空单元格的行数,由于数组rng是从第3行开始的,为了与下面引用的rng数组对应,所以需要减去2。全句是在C列和E列中逐一循环。

9、If d(CStr(rng(i, j))) <> \ :rng(i, j)是C列或者E列的股票代码,本句是如果这个股票代码关键字对应的项不等于空的时候,执行下面的代码。

10、arr(d(CStr(rng(i, j))), j - 2) = rng(i, j) :d(CStr(rng(i, j)))=i见上述6的解释,表示数组arr的第1维,相当于行;j-2是随着j=3的时候,j-2=1;j=5的时候j-2=3,相当于数组列的参数。把相应的股票代码赋给相同股票代码的第1列或者是第3列。 11、arr(d(CStr(rng(i, j))), j - 1) = rng(i, j + 1) :把相应的股票名称赋给相同股票代码的第2列或者是第4列。

12、[c3].Resize(UBound(rng), 4) = arr :把数组arr赋给C3开始的单元格区域。

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

29

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

图 实例7-2示例

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

一、问题的提出:

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

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

30

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

图 实例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(\Myr =[b65536].End(xlUp).Row Arr = Range(\& 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

31

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

.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, \

32

联系客服:779662525#qq.com(#替换为@)