字典怎么玩？A列B列数据比较

香川群子 · 发表于 2015-10-8 11:07

看到1个有趣的题目：使用字典对A列B列数据进行比较

要求输出4种不重复统计结果：
1. A列有B列没有即A1B0
2. B列有A列没有即A0B1
3. A列有B列也有即A1B1
4. A列有或B列有即A+B (A or B)

请看参考附件。

香川群子 · 发表于 2015-10-8 11:09

代码及注释。

Option Base 1
Sub test()
Dim ar, dic, i&, k1&, k2&, k3&, k4&, m&, t$, tr, tms#
tms = Timer
[d1].CurrentRegion.Offset(1) = "" '清空输出区域
m1 = [a65536].End(3).Row - 1 '获取A列最大行数m1
ar = [a2].Resize(m1) '读取A列数据到数组ar
m2 = [b65536].End(3).Row - 1 '获取B列最大行数m2
ReDim br1(m1, 1), br2(m2, 1), br3(m1, 1), br4(m1 + m2, 1)
'建立存放结果的数组br1、br2、br3、br4 (不超过可能个数)
Set dic = CreateObject("Scripting.Dictionary") '建立字典dic
For i = 1 To m1 '遍历A列数据
t = ar(i, 1): If Len(t) Then If Not dic.Exists(t) Then dic(t) = t: k4 = k4 + 1: br4(k4, 1) = t
'如不为空则检查是否已经存入字典、并将第1次结果存入br4 即【A+B合成】(A or B)
Next
ar = [b2].Resize(m2) '读取B列数据到数组ar (数组ar重复使用)
For i = 1 To m2 '遍历B列数据
t = ar(i, 1)
If Len(t) Then '如不为空
If dic.Exists(t) Then '如字典存在则A1B1 即AB都有
If Len(dic(t)) Then dic(t) = "": k3 = k3 + 1: br3(k3, 1) = t
'如字典Item结果不为空则属于第1次出现，标记Item为空并记入br3【AB都有】
'如Item为空则为标记已重复不用统计【重要技巧】
Else '如字典不存在 A0B1 即B有A没有
k2 = k2 + 1: br2(k2, 1) = t '记入br2【B有A没有】
k4 = k4 + 1: br4(k4, 1) = t '记入br4【A+B合成】(A or B)
dic(t) = "" '该值Item标记为空防止重复统计【重要技巧】
End If
End If
Next
'以上检查完毕，但A有B没有结果只存在于字典中，还需要检查输出
tr = dic.items '提取字典中结果（A有B有时为空、B有时为空、仅A有B没有才是结果）
For i = 0 To UBound(tr) '遍历字典结果
t = tr(i): If Len(t) Then k1 = k1 + 1: br1(k1, 1) = t
'如果Item不为空才是仅A有B没有的正确结果输出到br1
Next
'以下为输出
[d2].Resize(k1) = br1
[e2].Resize(k2) = br2
[f2].Resize(k3) = br3
[g2].Resize(k4) = br4
MsgBox Format(Timer - tms, "0.00s")
End Sub

复制代码

香川群子 · 发表于 2015-10-8 11:33

再换一种算法：
使用1个字典、A列B列各一次循环，最后对字典结果再进行一次循环检查以便输出结果：

Sub test2()
Dim ar, kr, tr, dic, i&, k1&, k2&, k3&, k4&, m&, r&, t$, tms#
tms = Timer
[d1].CurrentRegion.Offset(1) = ""
m = [a65536].End(3).Row - 1
ar = [a2].Resize(m)
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To m
t = ar(i, 1): If Len(t) Then dic(t) = 1 'A列有标记=1
Next
m = [b65536].End(3).Row - 1
ar = [b2].Resize(m)
For i = 1 To m
t = ar(i, 1)
If Len(t) Then
If Not dic.Exists(t) Then 'A0B1
dic(t) = 2 'A没有B有标记为=2
Else
If dic(t) = 1 Then dic(t) = 3 '标记=1时则为A有且B有改标记=3
End If
End If
Next
kr = dic.keys
tr = dic.items
ReDim br(1 To dic.Count, 1 To 4)
For i = 0 To dic.Count - 1
r = tr(i): t = kr(i)
If r = 1 Then k1 = k1 + 1: br(k1, 1) = t '标记=1时仅A有B没有
If r = 2 Then k2 = k2 + 1: br(k2, 2) = t '标记=2时仅B有A没有
If r = 3 Then k3 = k3 + 1: br(k3, 3) = t '标记=3时A有B也有
k4 = k4 + 1: br(k4, 4) = t '字典中留下的就是A+B合成(A有 or B有)
Next
MsgBox Format(Timer - tms, "0.00s")
[d2].Resize(dic.Count, 4) = br
End Sub

复制代码

小花鹿 · 发表于 2015-10-8 12:26

参与一下：
Sub test1()
Dim d, d1, r&, i&, ar, br(1 To 65536, 1 To 4), n1&, n2&, n3&, n4&, dk, t
t = Timer
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
r = [a65536].End(3).Row
i = [b65536].End(3).Row
If r < i Then r = i
ar = Range("a2:b" & r)
For i = 1 To r - 1
If ar(i, 1) <> "" Then d(ar(i, 1)) = ""
If ar(i, 2) <> "" Then d1(ar(i, 2)) = ""
Next i
dk = d.keys
For i = 0 To UBound(dk)
n4 = n4 + 1
br(n4, 4) = dk(i)
If d1.exists(dk(i)) = 0 Then
      n1 = n1 + 1
      br(n1, 1) = dk(i)
Else
      n3 = n3 + 1
      br(n3, 3) = dk(i)
End If
Next i
dk = d1.keys
For i = 0 To UBound(dk)
If d.exists(dk(i)) = 0 Then
      n4 = n4 + 1
      br(n4, 4) = dk(i)
      n2 = n2 + 1
      br(n2, 2) = dk(i)
End If
Next i
[r2].Resize(n4, 4) = br
MsgBox Timer - t
End Sub

zhouzhongchi · 发表于 2015-10-8 14:12

学习香川群子的技巧：在Item上耍花枪。无需remove

香川群子 · 发表于 2015-10-8 15:37

如果使用4个字典分别存放4种不同类型结果，那么代码如下：
显然这么做速度效率比较低。但逻辑比较容易懂。

Sub test4()
Dim ar, dic1, dic2, dic3, dic4, i&, m&, t$, tms#
tms = Timer
m = [a65536].End(3).Row - 1
ar = [a2].Resize(m)
Set dic1 = CreateObject("Scripting.Dictionary") 'A1B0
Set dic2 = CreateObject("Scripting.Dictionary") 'A0B1
Set dic3 = CreateObject("Scripting.Dictionary") 'A1B1
Set dic4 = CreateObject("Scripting.Dictionary") 'A+B
For i = 1 To m
t = ar(i, 1): If Len(t) Then dic1(t) = "": dic4(t) = ""
Next
m = [b65536].End(3).Row - 1
ar = [b2].Resize(m)
For i = 1 To m
t = ar(i, 1)
If Len(t) Then
dic4(t) = "" 'A+B
If Not dic3.exists(t) Then
If dic1.exists(t) Then 'A1B1
dic1.Remove t
dic3(t) = "" 'A1B1
Else
dic2(t) = "" 'A0B1
End If
End If
End If
Next
MsgBox Format(Timer - tms, "0.00s")
[d1].CurrentRegion.Offset(1) = ""
[d2].Resize(dic1.Count) = WorksheetFunction.Transpose(dic1.keys)
[e2].Resize(dic2.Count) = WorksheetFunction.Transpose(dic2.keys)
[f2].Resize(dic3.Count) = WorksheetFunction.Transpose(dic3.keys)
[g2].Resize(dic4.Count) = WorksheetFunction.Transpose(dic4.keys)
End Sub

复制代码

香川群子 · 发表于 2015-10-8 15:39

本帖最后由香川群子于 2015-10-8 23:24 编辑

4楼小花鹿的是双字典法，需要对2个字典各自检查结果。

改写如下:

Sub test3()
Dim ar, kr, dic1, dic2, i&, k1&, k2&, k3&, k4&, m&, t$, tms#
tms = Timer
m = [a65536].End(3).Row - 1
ar = [a2].Resize(m)
Set dic1 = CreateObject("Scripting.Dictionary") 'A
For i = 1 To m
t = ar(i, 1): If Len(t) Then dic1(t) = ""
Next
m = [b65536].End(3).Row - 1
ar = [b2].Resize(m)
Set dic2 = CreateObject("Scripting.Dictionary") 'B
For i = 1 To m
t = ar(i, 1): If Len(t) Then dic2(t) = ""
Next
ReDim br(1 To dic1.Count + dic2.Count, 1 To 4)
kr = dic1.keys
For i = 0 To UBound(kr)
t = kr(i)
If Not dic2.exists(t) Then
k1 = k1 + 1: br(k1, 1) = t
Else
k3 = k3 + 1: br(k3, 3) = t
End If
k4 = k4 + 1: br(k4, 4) = t
Next
kr = dic2.keys
For i = 0 To UBound(kr)
t = kr(i)
If Not dic1.exists(t) Then
k2 = k2 + 1: br(k2, 2) = t
k4 = k4 + 1: br(k4, 4) = t
End If
Next
' Exit Sub
MsgBox Format(Timer - tms, "0.00s")
[d1].CurrentRegion.Offset(1) = ""
[d2].Resize(k4, 4) = br
End Sub

复制代码

A+B输出错误已更正

dffddd · 发表于 2015-10-9 10:39

小花鹿发表于 2015-10-8 12:26
参与一下：
Sub test1()
Dim d, d1, r&, i&, ar, br(1 To 65536, 1 To 4), n1&, n2&, n3&, n4&, dk, t

在什么情况下用两个字典？

huang1314wei · 发表于 2015-10-9 12:56

dffddd 发表于 2015-10-9 10:39
在什么情况下用两个字典？

根据实际需要

aman1516 · 发表于 2015-10-10 21:28

加深理解，灵活应用字典

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

[讨论] 字典怎么玩？A列B列数据比较

评分

点评

评分

评分

评分