[已解决]求提速

rangevba

求提速

1、b3开始的b列各单元格分别填有不同的数据且每2个数字间空1格。

2、c3开始的c列各单元格分别填有不同的条件数据，以等号为界，等号右边数字每2个数字间空1格,等号左边为区间条件，表示等号右边的数据与b列某个单元格数据个数相同的数据个数。
如c列条件：
1-2=3 8 15 21 23
表示在：3 8 15 21 23         这5个数中有1到2个与b列某个单元格数据相同的个数（也就是大家都有的数据）。
0-3=4 12 15 20 33 35 36
表示在：4 12 15 20 33 35 36  这7个数中有0到3个与b列某个单元格数据相同的个数（也就是大家都有的数据）。

3、c3开始的c列，每行为一个条件每21行为1组，即c3：c23为第1组，c24：c44为第2组，c45：c65为第3组。。。。。。

4、点击按钮后c3开始的c列各大组（21行）中，首先一次求出同时满足c列前12条的b列数据，从第13条开始对同时满足c列前12条的b列数据过滤并提取符合条件的数据，第14条开始对同时满足c13的b列数据过滤提取符合条件的数据，依次...当b列符合条件的组数为1组时停止查找并将b列这1组数据依次提取并填写在e3开始的e列各单元格，
5、如第一组：c3-c23,首先一次求出同时满足c3-c14共12条条件的b列数据，c15开始对同时满足c3-c14共12条条件的b列数据过滤并提取符合条件的数据，c16条开始对同时满足c15的b列数据过滤提取符合条件的数据，依次......
6、就是将各组21条条件分成2个部分，前12条一次求出，后9条作为微条数据逐一对前1条数据过滤并提取符合条件的数据。
7、现附件中有二个按钮并附有程序，请老师看看这二个程序还能否提速，如能请修改，谢谢，另“请提速这个程序”这个按钮是一次出结果，按钮4采用d列为铺助列，其运行速度（数据b列5万行，c列8000行）比“请提速这个程序”这个按钮快1/3，请老师看看能否取消d列铺助列将上下二段合一，谢谢！

21-提速（修）.zip (31.21 KB, 下载次数: 16)

2016-4-26 09:55 上传

点击文件名下载附件

原附件按钮4的：set rng =range("fh5:fh &（"fh1048576").end(3).row) 改为：set rng =range("d3:d &("d1048576").end(3).row)

最佳答案

月排行榜 / 总排行榜

grf1973

2016-4-27 17:05

为掌握进度，用即时显示的方式，防止误以为死机。

1. Dim brr()
   
2. Sub grf_4()     '先分每组，后遍历每条数据，找出符合本组21个条件的第1条数据
   
3.     tt = Timer
   
4.     Range("f3:f1048576").ClearContents
   
5.     brr = Range("b3:b" & [b65536].End(3).Row)
   
6.     crr = Range("c3:e" & [c65536].End(3).Row)
   
7.     xstep = 40     '每组多少行
   
8.     ReDim err(1 To UBound(crr) / xstep + 1, 1 To 2)
   
9.    
   
10.     For i = 1 To UBound(brr)     '把数据源串成字符串作为每组第1条条件的比较对象
    
11.         b0 = b0 & "," & i
    
12.     Next
    
13.     b0 = Mid(b0, 2)
    
14.     For i = 1 To UBound(crr) Step xstep      '分组，各组第一行为i
    
15.         bstr = b0      '每组第1条条件的比较对象
    
16.         Debug.Print i
    
17.         For k = 0 To xstep - 1  '每条数据和本组所有个条件相比对
    
18.             c = crr(i + k, 1) '本行条件
    
19.             bstr = GetB(bstr, c)  '用本次数据源进行比较，返回比较后的数据源
    
20.             If Len(bstr) = 0 Then GoTo 100     '如果本组所有条件未匹配完已无对应数据源，那么直接进入下一组
    
21.             If Len(bstr) And InStr(bstr, ",") = 0 Then     '表示符合本组条件的数据源只有一条
    
22.                 n = n + 1
    
23.                 err(n, 1) = brr(bstr, 1) & "(c" & i + 2 & ":c" & i + 22 & ")"  '记录下本数据及条件区域
    
24.                 Cells(n + 2, 6) = brr(bstr, 1) & "(c" & i + 2 & ":c" & i + 22 & ")"  '记录下本数据及条件区域
    
25.                 GoTo 100       '直接进入下一组
    
26.             End If
    
27.         Next k
    
28. 100:    Next i
    
29.         
    
30.     'If n > 0 Then [f3].Resize(n, 1) = err
    
31.     MsgBox Timer - tt
    
32. End Sub
    
33. Function GetB(bstr, c)     '数据源为bstr（字符串），符合条件c，返回所有符合条件的数据源
    
34.     xmin = Val(Left(c, 1))
    
35.     xmax = Val(Mid(c, 3, 1))
    
36.     cc = " " & Mid(c, 5) & " "     '条件两头加空格
    
37.     bb = Split(bstr, ",")
    
38.     For Each i In bb
    
39.         b = brr(i, 1)
    
40.         xrr = Split(b, " ")
    
41.         s = 0
    
42.         For Each x In xrr       '数据源和条件作比较
    
43.             If InStr(cc, " " & x & " ") > 0 Then
    
44.                 s = s + 1
    
45.                 If s > xmax Then Exit For
    
46.             End If
    
47.         Next
    
48.         If s >= xmin And s <= xmax Then GetB = GetB & "," & i
    
49.     Next
    
50.     GetB = Mid(GetB, 2)
    
51. End Function

复制代码

跳转到最佳答案楼层

grf1973

顶一下，请算法高手出手。

上清宫主

不想细看代码
实现什么功能的？

grf1973

现在的思路是C列第1行条件和B列数据逐条比较，把符合条件的数据组成集合1；然后第2行条件和集合1比较，得到集合2；第3行和集合2比较，得出集合3.。。。。一直到集合里只剩下1条数据为止。

vbyou127

果然高手又在玩彩票，好有钱途啊

grf1973

自己琢磨了一下，换了个思路，分组后遍历每一条记录，对比本组每一个条件，找到符合本组所有条件的第一条数据（这样的话，如果数据量很大的话，找到第一条数据后就可以直接去下一组，避免了很多无效运算）

另外改写了比较b c的函数（前提是条件只能是?-?=*****型，等号前面只有3位）

1. Sub grf_3()     '先分每组，后遍历每条数据，找出符合本组21个条件的第1条数据
   
2.     tt = Timer
   
3.     Range("f3:f1048576").ClearContents
   
4.     brr = Range("b3:b" & [b65536].End(3).Row)
   
5.     crr = Range("c3:e" & [c65536].End(3).Row)
   
6.     Dim err(1 To 1000, 1 To 2)
   
7.     For i = 1 To UBound(crr) Step 21      '分组，各组第一行为i
   
8.         For ii = 1 To UBound(brr)   '遍历数据源
   
9.             b = brr(ii, 1)
   
10.             For k = 0 To 20    '每条数据和21个条件相比对
    
11.                 c = crr(i + k, 1) '本行条件
    
12.                 If Not ISOK(b, c) Then GoTo 100   '只要有一个条件不符合，直接下一条数据
    
13.             Next k
    
14.             n = n + 1             '到这里表示对数据b，21个条件均符合
    
15.             err(n, 1) = b & "(c" & i + 2 & ":c" & i + 22 & ")"   '记录下本数据及条件区域
    
16.             GoTo 200    '直接去下一组
    
17.            
    
18. 100:            Next ii
    
19. 200:    Next i
    
20.         
    
21.     If n > 0 Then [f3].Resize(n, 1) = err
    
22.     MsgBox Timer - tt
    
23. End Sub
    
24. 
    
25. Function ISOK(b, c) As Boolean    'B列某行是否符合C列某行条件
    
26.     xmin = Val(Left(c, 1))
    
27.     xmax = Val(Mid(c, 3, 1))
    
28.     xrr = Split(b, " ")
    
29.     cc = " " & Mid(c, 5) & " "     '条件两头加空格
    
30.     For Each x In xrr       '数据源和条件作比较
    
31.         If InStr(cc, " " & x & " ") > 0 Then
    
32.             s = s + 1
    
33.             If s > xmax Then Exit Function
    
34.         End If
    
35.     Next
    
36.     If s >= xmin Then ISOK = True
    
37. End Function

复制代码

grf1973

很奇怪，这次运行之后，符合条件的记录多了4条。原来的6条在结果里面。新增的好象也没错。
难道是上次的结果不对？请自行检验。

rangevba

grf1973 发表于 2016-4-26 20:34
很奇怪，这次运行之后，符合条件的记录多了4条。原来的6条在结果里面。新增的好象也没错。
难道是上次的结 ...

老师你好，测试了一下程序，结果10条是不对的（6条是对的）：
1、你在程序中对结果的限制不对，题目要求是：各大组21行从12行的结果开始依次增加条件到b列符合条件的组数为1组时停止查找并将b列这1组数据依次提取，而现在的程序刚好是提取了各大组21行结果的第1行。
2、附件c列条件共10大组，满足第1组21个条件的是9条（显然不符合1组这个条件数据全部放弃），满足第2组21个条件的是7条（显然不符合1组这个条件数据全部放弃），满足第3组21个条件的是3条（显然不符合1组这个条件数据全部放弃），满足第4组21个条件的是2条（显然不符合1组这个条件数据全部放弃），满足第5-10组21个条件的各是1条即共6条结果，程序刚好是将满足各大组21行结果的第1行提取了（见e列）因而与题意不符合！而各大组21条中，也许到15条就得到一组、也许到17条就得到一组、也许到21条就得到一组，情况是不一样的。
3、请老师增加个逐渐增加条件到b列符合条件的组数为1组时停止查找并将b列这1组数据依次提取的程序。

谢谢！

21-提速.rar (38.5 KB, 下载次数: 4)

2016-4-27 10:11 上传

点击文件名下载附件

grf1973

看看这次速度怎么样？

1. Sub grf_4()     '先分每组，后遍历每条数据，找出符合本组21个条件的第1条数据
   
2.     tt = Timer
   
3.     Range("f3:f1048576").ClearContents
   
4.     brr = Range("b3:b" & [b65536].End(3).Row)
   
5.     crr = Range("c3:e" & [c65536].End(3).Row)
   
6.     Dim err(1 To 1000, 1 To 2)
   
7.    
   
8.     For i = 1 To UBound(brr)     '把数据源串成字符串作为每组第1条条件的比较对象
   
9.         b0 = b0 & "," & brr(i, 1)
   
10.     Next
    
11.     b0 = Mid(b0, 2)
    
12.     For i = 1 To UBound(crr) Step 21      '分组，各组第一行为i
    
13.         bstr = b0      '每组第1条条件的比较对象
    
14.         For k = 0 To 20    '每条数据和21个条件相比对
    
15.             c = crr(i + k, 1) '本行条件
    
16.             bstr = GetB(bstr, c)  '用本次数据源进行比较，返回比较后的数据源
    
17.             If Len(bstr) And InStr(bstr, ",") = 0 Then     '表示符合本组条件的数据源只有一条
    
18.                 n = n + 1
    
19.                 err(n, 1) = bstr & "(c" & i + 2 & ":c" & i + 22 & ")"   '记录下本数据及条件区域
    
20.                 GoTo 100       '直接进入下一组
    
21.             End If
    
22.         Next k
    
23. 100:    Next i
    
24.         
    
25.     If n > 0 Then [f3].Resize(n, 1) = err
    
26.     MsgBox Timer - tt
    
27. End Sub
    
28. Function GetB(bstr, c)     '数据源为bstr（字符串），符合条件c，返回所有符合条件的数据源
    
29.     xmin = Val(Left(c, 1))
    
30.     xmax = Val(Mid(c, 3, 1))
    
31.     cc = " " & Mid(c, 5) & " "     '条件两头加空格
    
32.     bb = Split(bstr, ",")
    
33.     For Each b In bb
    
34.         xrr = Split(b, " ")
    
35.         s = 0
    
36.         For Each x In xrr       '数据源和条件作比较
    
37.             If InStr(cc, " " & x & " ") > 0 Then
    
38.                 s = s + 1
    
39.                 If s > xmax Then Exit For
    
40.             End If
    
41.         Next
    
42.         If s >= xmin And s <= xmax Then GetB = GetB & "," & b
    
43.     Next
    
44.     GetB = Mid(GetB, 2)
    
45. End Function
    

复制代码

grf1973

上清宫主 发表于 2016-4-26 11:37
不想细看代码
实现什么功能的？

替楼主解释一下要求：

1、 b3开始的b列各单元格分别填有不同的数据且每2个数字间空1格，此为数据源

2、 c3开始的c列各单元格分别填有不同的条件数据，以等号为界，等号右边数字每2个数字间空1格，此为条件源。条件源每21行为1组，c3：c23为第1组，c24：c44为第2组，c45：c65为第3组。。。。。。

3、  把数据源和每组条件源相比较，如果所有数据源中有且仅有1条与本组所有条件都匹配，那么记录下此条数据。

4、  条件匹配原则：条件类似1-2=38 15 21 23这种类型，等号左边为区间条件，表示等号右边的数据与b列某数据相同的数字个数。如c列条件：1-2=3 8 15 21 23，表示在：3 8 15 2123   这5个数中有1到2个与b列某条数据相同的数字个数（也就是大家都有的数字）。

5、遍历各组把所有符合条件的数据记录下来即为结果。