[分享]浅谈DICTIONARY(字典)对象

应用实例13  动态数据有效性

'模块代码

Public d As New Dictionary '定义字典对象

Sub createvaldition()
On Error Resume Next '忽略错误
Dim arr, i As Long
arr = Sheets("代码表").[a1].CurrentRegion
d.Add "all", "" '省市
For i = 1 To UBound(arr) '遍历
d.Add arr(i, 1), arr(i, 2) '地名查邮编
d.Add arr(i, 2), arr(i, 1) '邮编查地名
If arr(i, 2) Like "##0000" Then d("all") = d("all") & "," & arr(i, 1) '省级
If Mid(arr(i, 2), 3) > "0000" Then '省级以下
If Right(arr(i, 2), 2) = "00" Then '地市级
Mid(arr(i, 2), 3, 4) = "0000"
d(d(arr(i, 2))) = d(d(arr(i, 2))) & "," & arr(i, 1) '嵌套字典对象,反查
Else
Mid(arr(i, 2), 5, 2) = "00" '县区级
d(d(arr(i, 2))) = d(d(arr(i, 2))) & "," & arr(i, 1)
End If
End If
Next
    With [a2:a40].Validation '设置数据有效性
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Mid(d("all"), 2) '省份名称
        .IgnoreBlank = True
        .InCellDropdown = True
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With
End Sub

'工作表代码

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next '忽略错误
If Target.Column < 4 Then '前三列
If Len(Target.Text) > 0 Then
Cells(Target.Row, 4) = Left(d(Target.Value), 6) '不为空使用字典取其邮编置于第四列
Else
Target.Offset(, 1).Resize(1, 3) = "" '为空则删除右面单元格的内容
Cells(Target.Row, 4) = Left(d(Target.Offset(, -1).Value), 6) '取相邻左面单元格地名的邮编
End If
    With Target.Offset(, 1).Validation '设置右面单元格的数据有效性
        .Delete
       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Mid(d(Target.Value), 8)
        .IgnoreBlank = True
        .InCellDropdown = True
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With
End If
End Sub

33dSFbcl.rar (105.43 KB, 下载次数: 2165)

2007-9-10 23:03 上传

点击文件名下载附件
[分享]浅谈DICTIONARY(字典)对象

为什么这么好的地方总让斑竹们先占了呢？

呵呵，我也搬个板凳过来：）

版主辛苦，好贴！谢谢分亨

向狼兄请教一个问题:

字典的key\item只有一个,所有我看到的例子,情况一样,key是应该只有一个,而item最好能有多个的,实际中,表格内有多项内容是很普遍的,没办法,我是先join,后split,但感觉不爽,是否还有好的办法?

不是很明白你的问题.这个意思?

Sub macro1()
Dim i As Byte
With CreateObject("scripting.dictionary")
For i = 1 To 10
.Add 3 & "^" & i & "=" & 3 ^ i, i
.Add 4 & "^" & i & "=" & 4 ^ i, i
Next
MsgBox Join(.keys, vbCrLf)
MsgBox Join(.items, vbCrLf)
End With
End Sub

你传个附件看看

应用实例14 数据的快速查找

说明:这是字典的经典用法

Private Sub CommandButton1_Click() '随机排序
Application.ScreenUpdating = False
    Dim n As Long
    n = [a65536].End(xlUp).Row
    [a:a].Copy [d1]
    [e1].Resize(n, 1).Formula = "=rand()" '设随机数辅助列用于排序
    [d:e].Sort Key1:=Range("e1"), Order1:=xlAscending, Header:=xlNo '排序
    [e:e] = "" '清空辅助列
Application.ScreenUpdating = True
End Sub

AMXXTsrY.rar (14.13 KB, 下载次数: 1264)

2007-9-12 23:31 上传

点击文件名下载附件
[分享]浅谈DICTIONARY(字典)对象

支持！[em27]

谢谢版主分享。马上试做了一个，基本是安全照搬版主的代码，对代码的理解还是有点模糊。

显示1－100里含“3”的数字：

Sub dd()
Dim d As Object
Dim i As Long
Set d = CreateObject("scripting.dictionary")
For i = 1 To 100
If i Like "*" & 3 & "*" Then
d.Add i, ""
End If
Next
MsgBox Join(d.keys, vbCrLf)
Set d = Nothing
End Sub