多列数据取相同值

IRVING/123

有多列数据，数据的个数不等，我要求各列数据的相同值，也就是每列都有的值，应该怎么做？？？求思路

xiangbaoan

1. Sub test()
   
2. Dim ar, d As Object, i&, j&, s, k, n&
   
3. ar = [a1].CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For j = 1 To UBound(ar, 2)
   
6.     For i = 1 To UBound(ar)
   
7.         s = ar(i, j)
   
8.         If Len(s) Then d(s) = d(s) + 1
   
9.     Next
   
10. Next
    
11. For Each k In d.keys
    
12.     If d(k) = 5 Then
    
13.         n = n + 1
    
14.         Cells(n, "g") = k
    
15.     End If
    
16. Next
    
17. Set d = Nothing
    
18. End Sub

复制代码

wzsy2_mrf

用字典每列扫描一遍即可

719404338

1. Sub t()
   
2. Dim i, j, k, d
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. For i = 1 To UsedRange.Rows.Count
   
5.    For j = 1 To 5
   
6.        If Cells(i, j) <> "" Then
   
7.        d(Cells(i, j).Value) = ""
   
8.        End If
   
9.     Next j
   
10. Next i
    
11. i = 1
    
12. For Each sj In d
    
13.      k = 0
    
14.      For j = 1 To 5
    
15.          If Not Columns(j).Find(sj) Is Nothing Then
    
16.          k = k + 1
    
17.          End If
    
18.      Next j
    
19.      If k = 5 Then
    
20.      Range("h" & i) = sj
    
21.       i = i + 1
    
22.      End If
    
23. Next
    
24. End Sub

复制代码

duquancai

这5列 求交集！！！

zhenghui13

我的想法是如何每列的日期都是唯一的话，那么每个日期的计数项=5。通过这个来判断是否在每列都存在。
如果日期不是唯一的，可以比较复杂点。暂时的想法是：
1.定义另一个Array->brr,通过字典获取全部5列的唯一日期值。
2.定义每列日期列是否存在为0,1；
3.通过对每列，每列唯一值计数，=5表示都存在；输出.

1. 
   
2. 'Assume Each column has unique Date
   
3. Sub Unique_Item_In_Array()
   
4. Dim arr, i&, j&, k&
   
5. Dim dic As Object
   
6. Dim brr
   
7. Dim Sk As Date
   
8. Dim key
   
9. Dim Flag As Boolean
   
10. 
    
11. Set dic = CreateObject("Scripting.Dictionary")
    
12. arr = Sheet1.UsedRange
    
13. 'ReDim brr(1 To UBound(arr), 1 To 5)
    
14. i = 1
    
15. Do While i >= LBound(arr) And i <= UBound(arr)
    
16.     j = 1
    
17.     Do While j >= 1 And j <= UBound(arr, 2)
    
18.          Sk = arr(i, j)
    
19.          dic(Sk) = dic(Sk) + 1     'Count Date
    
20.          j = j + 1
    
21.     Loop
    
22.     i = i + 1
    
23. Loop
    
24. 
    
25. key = dic.keys
    
26. k = 0
    
27. For i = 0 To UBound(key)
    
28.     If dic(key(i)) = 5 Then
    
29.         k = k + 1
    
30.         Sheet2.Cells(k, 1) = key(i)
    
31.     End If
    
32. Next i
    
33. Debug.Print Timer
    
34. End Sub
    

复制代码

duquancai

1. # -*- coding: utf-8 -*-
   
2. # version: Python 3.7.0
   
3. 
   
4. A = ['2019/1/1','2019/1/2','2019/1/3','2019/1/4','2019/1/5','2019/1/6','2019/1/7','2019/1/8','2019/1/9','2019/1/10']
   
5. B = ['2019/1/1','2019/1/2','2019/1/5','2019/1/6','2019/1/7','2019/1/8','2019/1/9','2019/1/10','2019/1/21','2019/1/22','2019/1/23','2019/1/24','2019/1/25','2019/1/26','2019/1/27','2019/1/28','2019/1/29']
   
6. C = ['2019/1/1','2019/1/4','2019/1/5','2019/1/6','2019/1/7','2019/1/8','2019/1/9','2019/1/10','2019/1/11']
   
7. D = ['2019/1/1','2019/1/2','2019/1/3','2019/1/4','2019/1/5','2019/1/6','2019/1/7','2019/1/8','2019/1/9','2019/1/10']
   
8. E = ['2019/1/1','2019/1/2','2019/1/3','2019/1/4','2019/1/5','2019/1/6','2019/1/7','2019/1/8','2019/1/9']
   
9. 
   
10. res = set(A) & set(B) & set(C) & set(D) & set(E)
    
11. 
    
12. print(res)#输出结果！！！

复制代码

zhenghui13

duquancai 发表于 2019-4-21 19:45

EXCEL还没法支持 Python吧？ 关键是VBA不支持求交集或并集等运算。

lsc900707

增加代码灵活性;

1. Sub gj23w98()
   
2.     arr = [a1].CurrentRegion
   
3.     r = UBound(arr): c = UBound(arr, 2)
   
4.     ReDim brr(1 To UBound(arr), 1 To 1)
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For i = 1 To r
   
7.         For j = 1 To c
   
8.             s = arr(i, j)
   
9.             If Len(s) Then d(s) = d(s) + 1
   
10.         Next
    
11.     Next
    
12.     For Each k In d.keys
    
13.         If d(k) = c Then
    
14.             m = m + 1
    
15.             brr(m, 1) = k
    
16.         End If
    
17.     Next
    
18.     If m Then Cells(1, c + 3).Resize(m, 1) = brr
    
19. End Sub

复制代码

lsc900707

参考测试附件：