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

chenbiao2012 · 发表于 2021-12-18 20:12

蓝桥玄霜发表于 2010-10-18 12:53
实例7 字典法排序
一、问题的提出：
A列B列是按顺序排列的全部股票代码和股票名称，C列D列和E列F列是另 ...

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 arr, i%, mc$
Dim d As Object
Set d = CreateObject("scripting.dictionary")
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
      mc = IIf(Len(Trim(arr(i, 1))), arr(i, 1), arr(i - 1, 1))
      arr(i, 1) = mc
      d(mc) = d(mc) & arr(i, 2) & ","
Next
If Target.Column = 3 Then
      With Target.Validation
         .Delete
         .Add Type:=3, Formula1:=Join(d.keys, ",")
      End With
      Target.Offset(, 1) = ""
ElseIf Target.Column = 4 And Target.Offset(, -1) <> "" Then
      With Target.Validation
         .Delete
         .Add Type:=3, Formula1:=d(Target.Offset(, -1).Value)
      End With
End If
End Sub

chenbiao2012 · 发表于 2021-12-18 20:43

蓝桥玄霜发表于 2010-10-18 12:54
实例9 字典取行数，数组重新赋值
一、问题的提出：
要求编写一段代码，求得B列不重复的名字，其相应的A ...

这段代码设计有问题，如有64和98 排第1，与63和99排第1，按代码会全部提取

同心/ty · 发表于 2022-1-7 09:10

老师，学习了。

ls992204 · 发表于 2022-1-15 21:53

深奥的很。

wangqing29 · 发表于 2022-1-19 07:41

好详细，好好学

游乐缘 · 发表于 2022-1-19 09:36

感谢分享，认真学习

excel002009 · 发表于 2022-2-9 16:10

本帖最后由 excel002009 于 2022-2-9 20:21 编辑

蓝桥玄霜发表于 2010-10-18 12:53
实例7 字典法排序
一、问题的提出：
A列B列是按顺序排列的全部股票代码和股票名称，C列D列和E列F列是另 ...

n年没碰字典，再复习一下蓝版字典教程。实例8已经是比较靠后的一个字典例子，对字典的应用不彻底，原代码用数组替代也行，有点不合理。
改进下：

Dim d
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 i&, Myr&, Arr, cp$, tempStr$: tempStr = ""
Myr = Sheet1.[b65536].End(xlUp).Row
Arr = Sheet1.Range("a2:b" & Myr)
On Error GoTo 100
If Target.Column = 3 Then
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
If tempStr <> "" Then
d(tempStr) = Left(cp, Len(cp) - 1)
End If
tempStr = Arr(i, 1)
cp = ""
End If
cp = cp & Arr(i, 2) & ","
Next
d(tempStr) = Left(cp, Len(cp) - 1)
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
If d.exists(Target.Offset(0, -1).Value) Then
With Target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=d(Target.Offset(0, -1).Value)
End With
End If
Target = Split(d(Target.Offset(0, -1).Value), ",")(0)
End If
Exit Sub
100:
MsgBox "请先选择一级下拉选"
End Sub

复制代码

excel002009 · 发表于 2022-2-12 17:11

蓝桥玄霜发表于 2010-10-18 12:54
实例9 字典取行数，数组重新赋值
一、问题的提出：
要求编写一段代码，求得B列不重复的名字，其相应的A ...

实例9有误字典存的项应该是k，数据特殊未暴露。

Sub a()
Dim arr, d, k%, i%, j%
Set d = CreateObject("Scripting.Dictionary")
arr = Sheet1.UsedRange
For i = 2 To UBound(arr)
If Not d.Exists(arr(i, 2)) Then
k = k + 1
d(arr(i, 2)) = k
If i <> k Then
For j = 1 To UBound(arr, 2)
arr(k, j) = arr(i, j)
Next
End If
Else
arr(d(arr(i, 2)), 1) = CStr(arr(d(arr(i, 2)), 1)) + " " + CStr(arr(i, 1))
arr(d(arr(i, 2)), 4) = CStr(arr(d(arr(i, 2)), 4)) + " " + CStr(arr(i, 4))
arr(d(arr(i, 2)), 5) = Val(arr(d(arr(i, 2)), 5)) + Val(arr(i, 5))
arr(d(arr(i, 2)), 6) = Val(arr(d(arr(i, 2)), 6)) + Val(arr(i, 6))
End If
Next
With Sheet2
.Cells.ClearContents
.[a1:f1].Resize(d.Count) = arr
End With
End Sub

复制代码

excel002009 · 发表于 2022-2-12 19:47

蓝桥玄霜发表于 2010-10-18 12:54
实例9 字典取行数，数组重新赋值
一、问题的提出：
要求编写一段代码，求得B列不重复的名字，其相应的A ...

1

Sub pmcEx1()
Dim d, arr
Set d = CreateObject("scripting.dictionary")
arr = Range("a2:c" & Range("a" & Rows.Count).End(xlUp).Row)
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1) & "|" & arr(i, 3)) Then
d(arr(i, 1) & "|" & arr(i, 3)) = arr(i, 2)
Else
d(arr(i, 1) & "|" & arr(i, 3)) = Application.Max(Val(d(arr(i, 1) & "|" & arr(i, 3))), Val(arr(i, 2)))
End If
Next
[j:l].ClearContents
k = 0
For Each tempKey In d.keys
k = k + 1
[j1].Offset(k, 0) = Split(tempKey, "|")(0)
[j1].Offset(k, 2) = Split(tempKey, "|")(1)
[j1].Offset(k, 1) = d(tempKey)
Next
End Sub

复制代码

excel002009 · 发表于 2022-2-13 11:21

蓝桥玄霜发表于 2010-10-18 12:56
实例11 关键字赋给两列后用Replace方法
一、问题的提出：
有如图实例11-1所示的工资表，要求编写一段代 ...

实例11：

Sub realGame()
Dim d, arr(), i%, j%, k%, originArr
ReDim arr(1 To 5, 1 To 1)
k = 0
Set d = CreateObject("Scripting.Dictionary")
originArr = Range("a1").CurrentRegion
arr(1, 1) = "性别"
arr(2, 1) = "姓名"
For j = 1 To UBound(originArr, 2) Step 3
'每月工资标题
arr(Int(j / 3) + 3, 1) = originArr(1, j + 2)
For i = 2 To UBound(originArr)
If originArr(i, j) = "" Then Exit For
If Not d.exists(originArr(i, j) & "|" & originArr(i, j + 1)) Then
k = k + 1 '不重复员工计数
If k + 1 > UBound(arr, 2) Then 'arr当前容量不支持k行数据+1标题行
ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 10)
End If
d(originArr(i, j) & "|" & originArr(i, j + 1)) = k + 1 '每个不重复姓名映射自己所占用的列标
'在该员工自己占用列的一二行输入自己的性别、姓名
arr(1, k + 1) = originArr(i, j)
arr(2, k + 1) = originArr(i, j + 1)
End If
arr(Int(j / 3) + 3, d(originArr(i, j) & "|" & originArr(i, j + 1))) = originArr(i, j + 2)
Next
Next
[j:z].ClearContents
[j12].Resize(k + 1, 5) = Application.Transpose(arr)
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[原创] 常见字典用法集锦及代码详解