[已解决]多列数据交集

张雄友

求多列数据交集，已有效果，但没有数据出来。

1. Option Explicit
   
2. 
   
3. Sub 多列交集()
   
4.     Dim arr, brr, i&, j&, m&, n&, tms#, tmp$, s As Boolean, k&
   
5.     tms = Timer
   
6.     arr = Range("A2:G17")
   
7.     m = UBound(arr)
   
8.     n = UBound(arr, 2)
   
9.     ReDim brr(1 To m, 1 To 1)
   
10.     For i = 1 To m
    
11.         s = True
    
12.         tmp = arr(i, 1)
    
13.         For j = 2 To n
    
14.             If tmp <> arr(i, j) Then s = False: Exit For
    
15.         Next
    
16.         If s Then brr(i, 1) = tmp: k = k + 1
    
17.     Next
    
18.     [I2].Resize(Rows.Count - 1, 1).ClearContents: [I2].Resize(UBound(brr), 1) = brr
    
19.     MsgBox Format(Timer - tms, "0.00s ") & Chr(10) & "共找到" & Chr(10) & k & "个交集！"
    
20. End Sub
    

复制代码

最佳答案

月排行榜 / 总排行榜

grf1973

2015-11-2 14:15

换个思路

1. Sub 多列交集()
   
2.     Dim arr, i&, j&, tms#, k&, d, x
   
3.     tms = Timer
   
4.     arr = Range("A2:G17")
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For j = 1 To UBound(arr, 2)
   
7.         For i = 1 To UBound(arr)
   
8.             x = arr(i, j)
   
9.             If Val(d(x)) = j - 1 Then d(x) = j       '如果本列d(x)的值为列数-1，则d(x)取值为本列数
   
10.         Next
    
11.     Next
    
12.     For Each x In d.Keys
    
13.         If Len(x) = 0 Or d(x) < UBound(arr, 2) Then d.Remove x      '如果d(x)不等于总列数（说明不是每列都出现过，去掉）
    
14.     Next
    
15.     [J2].Resize(Rows.Count - 1, 1).ClearContents
    
16.     [J2].Resize(d.Count) = Application.Transpose(d.Keys)
    
17.     MsgBox Format(Timer - tms, "0.00s ") & Chr(10) & "共找到" & Chr(10) & d.Count & "个交集！"
    
18. End Sub
    

复制代码

跳转到最佳答案楼层

爱疯

如果不对，就说明一下需求



Sub test()
    Dim A, d, i, j, k, s, dKeys, dItems
    Set d = CreateObject("scripting.dictionary")
    A = Range("a1").CurrentRegion

    '1）求不重复值
    For i = 2 To UBound(A)
        For j = 1 To UBound(A, 2)
            If A(i, j) <> "" Then d(A(i, j)) = d(A(i, j)) + 1
        Next j
    Next i
    dKeys = d.Keys: dItems = d.items

    '2）判断次数
    For k = 0 To UBound(dItems)
        If dItems(k) < UBound(A, 2) Then
            d.Remove dKeys(k)
        Else
            '如果在某出现，则s=s+1
            s = 0
            For j = 1 To UBound(A, 2)
                For i = 2 To UBound(A)
                    If dKeys(k) = A(i, j) Then s = s + 1: Exit For
                Next i
            Next j
            '如果 s 达不到7次，就不是。
            If s < UBound(A, 2) Then d.Remove dKeys(k)
        End If
    Next k

    '3）结果
    [j2].Resize(d.Count) = Application.Transpose(d.Keys)
End Sub

grf1973

换个思路

1. Sub 多列交集()
   
2.     Dim arr, i&, j&, tms#, k&, d, x
   
3.     tms = Timer
   
4.     arr = Range("A2:G17")
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For j = 1 To UBound(arr, 2)
   
7.         For i = 1 To UBound(arr)
   
8.             x = arr(i, j)
   
9.             If Val(d(x)) = j - 1 Then d(x) = j       '如果本列d(x)的值为列数-1，则d(x)取值为本列数
   
10.         Next
    
11.     Next
    
12.     For Each x In d.Keys
    
13.         If Len(x) = 0 Or d(x) < UBound(arr, 2) Then d.Remove x      '如果d(x)不等于总列数（说明不是每列都出现过，去掉）
    
14.     Next
    
15.     [J2].Resize(Rows.Count - 1, 1).ClearContents
    
16.     [J2].Resize(d.Count) = Application.Transpose(d.Keys)
    
17.     MsgBox Format(Timer - tms, "0.00s ") & Chr(10) & "共找到" & Chr(10) & d.Count & "个交集！"
    
18. End Sub
    

复制代码

爱疯

grf1973 发表于 2015-11-2 14:15
换个思路

学习了！

val可以不用吧，是测试后忘删了么？

grf1973

应该可以吧，我怕d(x)为空的时候和j-1比较出现数据类型不匹配的错误。