[已解决]VBA分别计算交集和并集

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, drr, d, i&, p$, j%, s&, s2&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a10").CurrentRegion
   
5. brr = Range("h10").CurrentRegion
   
6. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2)) '交集
   
7. ReDim drr(1 To 60000, 1 To UBound(arr, 2)) '并集
   
8. For i = 2 To UBound(arr)
   
9.     p = ""
   
10.     For j = 1 To UBound(arr, 2)
    
11.         drr(i - 1, j) = arr(i, j)
    
12.         p = p & "," & arr(i, j)
    
13.     Next
    
14.     d(p) = ""
    
15. Next
    
16. s = UBound(arr) - 1
    
17. For i = 2 To UBound(brr)
    
18.     p = ""
    
19.     For j = 1 To UBound(brr, 2)
    
20.         p = p & "," & brr(i, j)
    
21.     Next
    
22.     If Not d.exists(p) Then
    
23.         s = s + 1
    
24.         For j = 1 To UBound(brr, 2)
    
25.             drr(s, j) = brr(i, j)
    
26.         Next
    
27.     Else
    
28.         s2 = s2 + 1
    
29.         For j = 1 To UBound(brr, 2)
    
30.             crr(s2, j) = brr(i, j)
    
31.         Next
    
32.     End If
    
33.     d(p) = ""
    
34. Next
    
35. Range("o11").Resize(s2, UBound(crr, 2)) = crr
    
36. Range("v11").Resize(s, UBound(drr, 2)) = drr
    
37. End Sub

复制代码

张雄友

dsmch 发表于 2015-4-24 18:25

不行的，运行时错误1004。

dsmch

张雄友 发表于 2015-4-24 20:38
不行的，运行时错误1004。

1. Sub 交集并集()
   
2. Dim arr, brr, drr, d, i&, p$, j%, s&, s2&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("A10").CurrentRegion
   
5. brr = Range("H10").CurrentRegion
   
6. n = UBound(arr, 2)
   
7. ReDim drr(1 To 60000, 1 To n) '并集
   
8. For i = 2 To UBound(arr)
   
9.     p = ""
   
10.     For j = 1 To n
    
11.         drr(i - 1, j) = arr(i, j)
    
12.         p = p & "," & arr(i, j)
    
13.     Next
    
14.     d(p) = ""
    
15. Next
    
16. s = UBound(arr) - 1
    
17. For i = 2 To UBound(brr)
    
18.     p = ""
    
19.     For j = 1 To n
    
20.         p = p & "," & brr(i, j)
    
21.     Next
    
22.     If Not d.exists(p) Then
    
23.         s = s + 1
    
24.         For j = 1 To n
    
25.             drr(s, j) = brr(i, j)
    
26.         Next
    
27.     Else
    
28.         s2 = s2 + 1
    
29.         Cells(i + 9, "h").Resize(1, n).Copy Cells(s2 + 10, "o")
    
30.     End If
    
31.     d(p) = ""
    
32. Next
    
33. Range("V11").Resize(s, n) = drr
    
34. End Sub

复制代码

dsmch

dsmch 发表于 2015-4-25 04:44

2楼代码发现：If s2 > 0 Then Range("A2").Resize(s2, UBound(crr, 2)) = crr 即可
多列可以，单列就不适应了。