[已解决]用VBA每行有5个数字相同就过滤 太慢如何改

grf1973

1. 用网友today的思路，0.2秒。
   
2. Sub today()
   
3.     Dim dic, d1, d2, i, j, arr, brr(), hh, k, hb, tem, x, t
   
4.     arr = Sheets(1).[a1].CurrentRegion
   
5.     t = Timer
   
6.     Sheets(2).Cells.Clear
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     Set d2 = CreateObject("scripting.dictionary")
   
10.     For i = 1 To UBound(arr)
    
11.         d2.RemoveAll
    
12.         For j = 1 To 6
    
13.             hb = ""
    
14.             For k = 1 To 6
    
15.                 If k <> j Then
    
16.                     hb = hb & arr(i, k) & ","
    
17.                 End If
    
18.             Next k
    
19.             If dic.exists(hb) Then
    
20.                 For Each x In d2.keys: dic.Remove (x): Next
    
21.                 GoTo 100
    
22.             Else
    
23.                 d2(hb) = ""
    
24.                 dic(hb) = ""
    
25.             End If
    
26.         Next j
    
27.         d1(i) = ""
    
28. 100:
    
29.     Next i
    
30.       
    
31.      hh = d1.keys
    
32.      ReDim brr(1 To d1.Count, 1 To 6)
    
33.      For i = 0 To UBound(hh)
    
34.         For j = 1 To 6
    
35.             brr(i + 1, j) = arr(hh(i), j)
    
36.         Next j
    
37.     Next i
    
38.    
    
39.     Sheets(2).[a1].Resize(i, 6) = brr
    
40.     MsgBox Timer - t
    
41. End Sub

复制代码

vbyou127

grf1973 发表于 2016-6-21 15:41

1,没有标准答案，不同算法结果差几行属于正常

2，谁是today

3,两个都不能运行，不知道为何

grf1973

原先代码为美观，显示在新表中。现按原显示要求作了修改，并对几个代码作了比较。

vbyou127

grf1973 发表于 2016-6-22 09:23
原先代码为美观，显示在新表中。现按原显示要求作了修改，并对几个代码作了比较。

today太快了

香川群子

grf1973 发表于 2016-6-21 15:41

思路正确。但是只需用1个字典即可。速度快1倍。

1. Sub test() 'by kagawa
   
2.     Dim i&, i1&, i2&, k&, m&, n&,s$, tms#
   
3.     tms = Timer
   
4.    
   
5.     ar = [a11].CurrentRegion
   
6.     m = UBound(ar): n = UBound(ar, 2)
   
7.     ReDim t$(1 To n)
   
8.    
   
9.     Set d = CreateObject("Scripting.Dictionary")
   
10.     For i = 1 To m
    
11.         For i1 = 1 To n
    
12.             s = ""
    
13.             For i2 = 1 To n
    
14.                 If i1 <> i2 Then s = s & "," & ar(i, i2) '生成6选5组合s
    
15.             Next
    
16.             If d.Exists(s) Then Exit For Else t(i1) = s '检查是否已有
    
17.         Next
    
18.         
    
19.         If i1 > n Then '如6个组合都不存在则本行有效
    
20.             k = k + 1
    
21.             For i2 = 1 To n
    
22.                 ar(k, i2) = ar(i, i2): d(t(i2)) = "" '复制数据并加入字典
    
23.             Next
    
24.         End If
    
25.     Next
    
26.    
    
27.     [p11].CurrentRegion = ""
    
28.     [p11].Resize(k, n) = ar
    
29.     MsgBox Format(Timer - tms, "0.00s ") & k & "/" & d.Count
    
30. End Sub

复制代码

香川群子

如果不考虑通用性，则直接写代码速度最快：

1. Sub test1()
   
2.     Dim ar, d, i&, j&, k&, m&, n&, t1$, t2$, t3$, t4$, t5$, t6$, tms#
   
3.     tms = Timer
   
4.     ar = [a11].CurrentRegion
   
5.     m = UBound(ar): n = UBound(ar, 2)
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     For i = 1 To m
   
8.         t1 = ar(i, 1) & "," & ar(i, 2) & "," & ar(i, 3) & "," & ar(i, 4) & "," & ar(i, 5)
   
9.         If Not d.Exists(t1) Then
   
10.           t2 = ar(i, 1) & "," & ar(i, 2) & "," & ar(i, 3) & "," & ar(i, 4) & "," & ar(i, 6)
    
11.           If Not d.Exists(t2) Then
    
12.             t3 = ar(i, 1) & "," & ar(i, 2) & "," & ar(i, 3) & "," & ar(i, 5) & "," & ar(i, 6)
    
13.             If Not d.Exists(t3) Then
    
14.               t4 = ar(i, 1) & "," & ar(i, 2) & "," & ar(i, 4) & "," & ar(i, 5) & "," & ar(i, 6)
    
15.               If Not d.Exists(t4) Then
    
16.                 t5 = ar(i, 1) & "," & ar(i, 3) & "," & ar(i, 4) & "," & ar(i, 5) & "," & ar(i, 6)
    
17.                 If Not d.Exists(t5) Then
    
18.                   t6 = ar(i, 2) & "," & ar(i, 3) & "," & ar(i, 4) & "," & ar(i, 5) & "," & ar(i, 6)
    
19.                   If Not d.Exists(t6) Then
    
20.                     k = k + 1
    
21.                     For j = 1 To n
    
22.                         ar(k, j) = ar(i, j)
    
23.                     Next
    
24.                     d(t1) = "": d(t2) = "": d(t3) = "": d(t4) = "": d(t5) = "": d(t6) = ""
    
25.                   End If
    
26.                 End If
    
27.               End If
    
28.             End If
    
29.           End If
    
30.         End If
    
31.     Next
    
32.     [p11].CurrentRegion = ""
    
33.     [p11].Resize(k, n) = ar
    
34.     MsgBox Format(Timer - tms, "0.00s ") & k & "/" & d.Count
    
35. End Sub

复制代码

l00l00

我试了一个代码，0.1秒。  主要是原数据结构规则，有排序，不然0.2秒以上至少。

香川群子

vbyou127 发表于 2016-6-22 09:31
today太快了

16楼的代码才是最快。

grf1973

香川群子 发表于 2016-6-22 12:16
思路正确。但是只需用1个字典即可。速度快1倍。

高，实在是高。

today0427

我是闻讯来学习的！高，实在是高！