[已解决]字典法查找相同与不同并列出

shixyi37 · 发表于 2016-11-13 10:59

Sub 字典法()
arr1 = Range("A2:A14")
arr2 = Range("B2:B14")
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr1)
d(arr1(i, 1)) = 0
Next
For j = 1 To UBound(arr2)
If d.exists(arr2(j, 1)) Then d(arr2(j, 1)) = 1
Next
For Each d1 In d.keys
If d(d1) = 0 Then d.Remove (d1)
Next
Range("D2").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
End Sub
上述代码是查找两列数据中同相的数据并列出到D列，想同时把A列不相同的列出到E列，把B列不相同的列出到F列，怎么改代码？如下图：

字典法查找相同.zip (9.76 KB, 下载次数: 23)

yeminqiang · 发表于 2016-11-13 14:12

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

复制代码

上清宫主 · 发表于 2016-11-13 21:36

Sub 字典法()
Dim arr1(), arr2(), d, d1
arr1 = Range("A2:A14").Value
arr2 = Range("B2:B14").Value
Set d = CreateObject("Scripting.Dictionary")
For i% = 1 To UBound(arr1)
d(arr1(i, 1)) = 1
Next
For j% = 1 To UBound(arr2)
d(arr2(j, 1)) = 10 + d(arr2(j, 1))
Next
i = 0: j = 0: l% = 0
ReDim arr1(d.Count, 2)
For Each d1 In d.keys
If d(d1) = 1 Then
      arr1(j, 1) = d1: j = j + 1
      If m% < j Then m = j
ElseIf Right(d(d1), 1) = 0 Then
      arr1(l, 2) = d1: l = l + 1
      If m% < l Then m = l
Else
   arr1(i, 0) = d1: i = i + 1
   If m% < i Then m = i
End If
Next
Range("d2").Resize(m, 3) = arr1
End Sub

上清宫主 · 发表于 2016-11-13 21:47

省个循环
Sub 字典法()
Dim arr1(), d, d1
arr1 = Range("A2:B40").Value
Set d = CreateObject("Scripting.Dictionary")
For i% = 1 To UBound(arr1)
If Right(d(arr1(i, 1)), 1) <> 1 Then d(arr1(i, 1)) = 1 + d(arr1(i, 1))
If d(arr1(i, 2)) < 10 Then d(arr1(i, 2)) = 10 + d(arr1(i, 2))
Next
i = 0: j = 0: l% = 0
ReDim arr1(d.Count, 2)
For Each d1 In d.keys
If d(d1) = 1 Then
      arr1(j, 1) = d1: j = j + 1
      If m% < j Then m = j
ElseIf d(d1) = 10 Then
      arr1(l, 2) = d1: l = l + 1
      If m% < l Then m = l
Else
   arr1(i, 0) = d1: i = i + 1
   If m% < i Then m = i
End If
Next
Range("d2").Resize(m, 3) = arr1
End Sub

yeminqiang · 发表于 2016-11-19 17:45

2楼的代码是想穿裙子女侠写的，本人只是搬砖而已。

雄鹰2013 · 发表于 2017-9-4 15:01

Sub 相同与不同()
Dim arr(), x, y, z
Set d = CreateObject("scripting.dictionary")
arr = Range("a2:b100")
For i = 1 To UBound(arr)
   If d(arr(i, 1)) <> 1 Then d(arr(i, 1)) = d(arr(i, 1)) + 1 '第一列出现的数字都编号为1
   If d(arr(i, 2)) <> 2 Then d(arr(i, 2)) = d(arr(i, 2)) + 2 '第二列出现的数字都编号为2
Next i
x = 0: y = 0: z = 0
ReDim arr(d.Count, 2)  '编号都是0开始
For Each k In d.keys
   If d(k) = 1 Then
      arr(x, 1) = k: x = x + 1 '第一列不同
      If m < x Then m = x
   ElseIf d(k) = 2 Then
      arr(y, 2) = k: y = y + 1 '第二列不同
      If m < y Then m = y
   Else
      arr(z, 0) = k: z = z + 1 '都相同
      If m < z Then m = z
   End If
Next k
Range("d2").Resize(m, 3) = arr
End Sub

雄鹰2013 · 发表于 2017-9-4 15:01

修改了一下，感觉这个理解起来简单

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

[已解决]字典法查找相同与不同并列出

评分