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

huangyz_xy

香川群子 发表于 2015-10-8 15:39
4楼小花鹿的是双字典法，需要对2个字典各自检查结果。

改写如下:

如果把你回复的"机构名称匹配检查"和这个合在一起那就完美了，可惜，才疏学浅，不会这么多！

qx-liuwx

每次回帖、谢谢！辛苦了。

香川群子

huangyz_xy 发表于 2015-11-23 14:13
如果把你回复的"机构名称匹配检查"和这个合在一起那就完美了，可惜，才疏学浅，不会这么多！

本帖题目只要求比对完全相同的，而"机构名称匹配检查"要求匹配相似的。实际差异较大。

sunny_8848

学习好代码，前段时间还请在教两列数据比较并去重

m_n_j001

3楼的代码很眼熟
不同在于：对A列排除空值后直接dic(t) = 1，对B列排除空值后if dic(t) < 2 then dic(t) = dic(t) + 2

蔡明江

收藏了，谢谢

deepbox

学习一下，深受启发

hb662868

好好学习，天天向上

chxw68

最近一直在学习香川群子老师的贴子，这个算是课后作业吧。

1. Sub test2()
   
2.   tms = Timer
   
3.   Dim r%, i%
   
4.   Dim arr, brr, m(1 To 4) As Integer
   
5.   Dim d As Object
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   With Worksheets("sheet1")
   
8.     .Range("d2:g" & .Rows.Count).ClearContents
   
9.     r = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(.Rows.Count, 2).End(xlUp).Row)
   
10.     arr = .Range("a2:b" & r)
    
11.     For j = 1 To UBound(arr, 2)
    
12.       For i = 1 To UBound(arr)
    
13.         If Len(arr(i, j)) <> 0 Then
    
14.           d(arr(i, j)) = d(arr(i, j)) Or j
    
15.         End If
    
16.       Next
    
17.     Next
    
18.     ReDim brr(1 To UBound(arr) * 2, 1 To 4)
    
19.     For Each aa In d.keys
    
20.       x = d(aa)
    
21.       m(4) = m(4) + 1
    
22.       brr(m(4), 4) = aa
    
23.       m(x) = m(x) + 1
    
24.       brr(m(x), x) = aa
    
25.     Next
    
26.     .Range("d2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
27.   End With
    
28.   MsgBox Format(Timer - tms, "0.00s")
    
29. End Sub

复制代码

一把小刀闯天下

'我也来练习一下，单字典，，，

Option Explicit

Sub test()
  Dim arr, m(4), p(2), i, j, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = Range("a2:b" & ActiveSheet.UsedRange.Rows.Count).Value
  ReDim brr(1 To UBound(arr, 1) * 2, 1 To 2), crr(1 To UBound(brr, 1), 1 To 4)
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
      If Len(arr(i, j)) > 0 Then
        If Not dic.exists(arr(i, j)) Then m(0) = m(0) + 1: dic(arr(i, j)) = m(0)
        brr(dic(arr(i, j)), j) = arr(i, j)
      End If
    Next
  Next
  For i = 1 To m(0)
    If Len(brr(i, 1)) > 0 And Len(brr(i, 2)) = 0 Then 'A有B没有
      p(1) = 1: p(2) = 1
    ElseIf Len(brr(i, 1)) = 0 And Len(brr(i, 2)) > 0 Then 'B有A没有
      p(1) = 2: p(2) = 2
    Else 'A、B共有
      p(1) = 3: p(2) = 1
    End If
    m(p(1)) = m(p(1)) + 1: crr(m(p(1)), p(1)) = brr(i, p(2))
    m(4) = m(4) + 1: crr(m(4), 4) = brr(i, p(2))
  Next
  [r2].Resize(UBound(crr, 1), 4) = crr
End Sub