提取任意多行多列中每列都有的重复值,数据量大速度快

2801959927

1. =IFERROR(SMALL(IF(COUNTIF($A$2:$E$7,$A$2:$E$7)=COUNT($A$2:$E$2),$A$2:$E$7,""),ROW(A1)*COUNT($A$2:$E$2)),"")

复制代码

lizhipei78

洋务德雷 发表于 2023-3-29 19:59
你没有看我编写的vba吗？编写的就是这个思路呀

我看了一下，如果B:D列的每一列中均有多个重复值，你这个会不会出错？我的想法是先对每一列去重，然后再用你的方法应该会快很多。

吴中泉

lizhipei78 发表于 2023-3-30 16:54
我看了一下，如果B:D列的每一列中均有多个重复值，你这个会不会出错？我的想法是先对每一列去重，然后再 ...

已完美搞定，速度还很快，感谢原编者，提供了很好的算法和源程序
我感觉完美的代码如下，欢迎感兴趣的表哥表嫂们讨论交流。

1. Option Explicit
   
2. 
   
3. Sub Main()
   
4.     Dim d As Object, t
   
5.     Dim arr, c, i As Long, j As Long
   
6.     't = Timer
   
7.     arr = ActiveSheet.Range("a1").CurrentRegion
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     For i = 1 To UBound(arr)
   
10.           d(arr(i, 1)) = 0
    
11.     Next i
    
12.     'Stop
    
13.     For j = 2 To UBound(arr, 2)
    
14.           For i = 1 To UBound(arr)
    
15.               If d.exists(arr(i, j)) Then
    
16.                   d(arr(i, j)) = 1
    
17.               End If
    
18.           Next i
    
19.           For Each c In d.keys
    
20.               If d(c) < 1 Then
    
21.                   d.Remove (c)
    
22.               Else
    
23.                   d(c) = 0
    
24.               End If
    
25.           Next
    
26.     Next j
    
27.     'Stop
    
28.     Range("f2").Resize(i, 1).Clear
    
29.     Range("f2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
30.     Erase arr
    
31.     Set d = Nothing
    
32.     'MsgBox Timer - t
    
33. 
    
34. End Sub
    
35. '时间复杂度：O(n+n*列数)
    

复制代码

洋务德雷

lizhipei78 发表于 2023-3-30 16:54
我看了一下，如果B:D列的每一列中均有多个重复值，你这个会不会出错？我的想法是先对每一列去重，然后再 ...

你说得对，我忽略了这个情况。

xing_chen

洋务德雷 发表于 2023-3-30 22:02
你说得对，我忽略了这个情况。

老师，帮忙看下https://club.excelhome.net/thread-1657791-2-1.html 谢谢

zjzyj

字典exists方法速度很慢的，因为追求速度，所以不要用
用两个字典，先扔进第一个字典去重，然后再从第一个字典扔进第二个字典累加票数，最后把第二个字典中未获全票的键值对删除，剩余的就是需要的结果输出即可。

Sub tttt()

Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")

arr = Sheet1.Range("A1").CurrentRegion.Value
For j = 1 To UBound(arr, 2)
    For i = 1 To UBound(arr)
        d1(arr(i, j)) = ""
    Next
    For Each k In d1.keys
        d2(k) = d2(k) + 1
    Next
    d1.RemoveAll
Next

For Each k In d2.keys
    If d2(k) < UBound(arr, 2) Then
        d2.Remove k
    End If
Next

Sheet1.Range("J1").Resize(d2.Count) = WorksheetFunction.Transpose(d2.keys)

End Sub

洋务德雷

这回应该可以了。

吴中泉

zjzyj 发表于 2023-3-30 22:36
字典exists方法速度很慢的，因为追求速度，所以不要用
用两个字典，先扔进第一个字典去重，然后再从第一个 ...

你这个程序我测试了一下，速度和我上面发的一样快，也是很不错的。就是多用一个字典

吴中泉

洋务德雷 发表于 2023-3-30 23:03
这回应该可以了。

感谢，辛苦啦