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

agstick

狼兄辛苦了！[em23][em23]

northwolves

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

省份	市名	县区名	邮编
天津市			120000
江西省	江西省新余市		360500
河北省	河北省保定市	河北省保定市郊区	130605

'模块代码

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(字典)对象

[此贴子已经被作者于2007-9-10 23:09:20编辑过]

xmh850216

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

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

xcd

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

smhf_6

向狼兄请教一个问题:

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

northwolves

QUOTE:

以下是引用smhf_6在2007-9-12 18:50:36的发言：

向狼兄请教一个问题:

字典的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

你传个附件看看

northwolves

应用实例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

Private Sub CommandButton2_Click() '数据快速查找

Application.ScreenUpdating = False
Dim n  As Long, i As Long, arr, t As Single
t = Timer
n = [a65536].End(xlUp).Row
arr = [a1].Resize(n, 2)
With CreateObject("scripting.dictionary") '建立字典
For i = 1 To n
.Add arr(i, 1), arr(i, 2) '顺序建立字典内容
Next
arr = [d1].Resize(n, 1)
For i = 1 To UBound(arr)
arr(i, 1) = .Item(arr(i, 1)) '在字典中按key取item
Next
End With
[e1].Resize(UBound(arr), 1) = arr
Application.ScreenUpdating = True
MsgBox "查找完成,用时" & Timer - t & "秒!" '速度还可以
End Sub

 

Private Sub CommandButton3_Click() '生成原始数据
   [a:b].ClearContents
    [a1] = "X1"
    [b1] = 1
    [b2] = 2
    [a1].AutoFill Destination:=Range("a1:a20000")
    [b1:b2].AutoFill Destination:=Range("b1:b20000")
 
End Sub

Private Sub CommandButton4_Click()
[a:e] = ""
End Sub

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

2007-9-12 23:31 上传

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

Long_III

支持！[em27]

leo_zp_yang

好贴，辛苦了。支持！

huiz999

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

显示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