[已解决]求依次增大区间分别对b3开始的b列各单元格的所有数字进行查找的vba程序

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列各组从第1个单元格开始到下一个各单元格数据依次增大区间分别对b3开始的b列各单元格的所有数字进行查找，当b列符合条件的组数为1组时停止查找并将b列这1组数据依次提取并填写在e3开始的e列各单元格，


5、计算顺序是：
依次查找依次填入，首先第1组条件开始查找，第1组条件查找完并提取数字后再接着第2组开始查找，第2组条件查找完并提取数字后再接着第3组开始查找。

第4点查找详细说明：
首先第1组条件开始查找，先用条件c3：c4开始查找，当b列同时符合c3：c4二个条件的组数大于1组时，再增加一个单元格：c3：c5，如b列同时符合c3：c5三个条件的组数大于1组时则再增加一个单元格：c3：c6，区间条件直到c3：c23为止而b列符合条件的组数为1组时停止查找，如果区间到最大c3：c23 b列都没有符合条件1组的组数则转入下一组；特别说明：b列的数据是同时符合c列的区间条件。


谢谢！
21-提取数据.rar (24.15 KB, 下载次数: 13)

2016-4-1 16:59 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-4-5 11:38

1. Sub grf()
   
2.     Cells.Interior.ColorIndex = 0
   
3.     [d3:d10000,e13:e1000].ClearContents
   
4.     brr = Range("b3:b" & [b65536].End(3).Row)
   
5.     crr = Range("c3:d" & [c65536].End(3).Row)
   
6.     ReDim drr(1 To UBound(crr), 1 To 1)
   
7.     ReDim err(1 To 1000, 1 To 2)
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.         For i = 1 To UBound(crr)
   
10.             tj = crr(i, 1)  '条件
    
11.             tj1 = Split(tj, "=")(0)
    
12.             xmin = Val(Split(tj1, "-")(0))
    
13.             xmax = Val(Split(tj1, "-")(1))
    
14.             tj2 = Split(tj, "=")(1)
    
15.             xrr = Split(tj2, " ")
    
16.             For Each x In xrr
    
17.                 d(x) = d(x) + 1
    
18.             Next
    
19.             For ii = 1 To UBound(brr)
    
20.                 xrr = Split(brr(ii, 1), " ")
    
21.                 s = 0
    
22.                 For Each x In xrr
    
23.                     If d.exists(x) Then s = s + 1
    
24.                 Next
    
25.                 If s >= xmin And s <= xmax Then drr(i, 1) = drr(i, 1) & "," & ii
    
26.             Next
    
27.             drr(i, 1) = Mid(drr(i, 1), 2)
    
28.             d.RemoveAll
    
29.         Next
    
30.         [d3].Resize(UBound(crr)) = drr    '第一步：得到drr，为crr中每个条件相符的brr中行号
    
31.         For h = 1 To UBound(crr) Step 20
    
32.             If UBound(crr) - h + 1 < 20 Then Exit For
    
33.             For p = h + 1 To h + 19      '从1：2行，到1：20行
    
34.                 d.RemoveAll:  zs = 0
    
35.                 For i = h To p
    
36.                     xrr = Split(drr(i, 1), ",")
    
37.                     For Each x In xrr
    
38.                         d(x) = d(x) + 1
    
39.                     Next
    
40.                 Next
    
41.                 For Each x In d.keys        'drr中h--p行某数出现的次数与行数相同，说明某数对应的brr数据与所有条件全符合
    
42.                     If d(x) = p - h + 1 Then zs = zs + 1: xstr = x
    
43.                 Next
    
44.                 If zs = 1 Then     '第二步：得到drr中组数为1的brr的行号
    
45.                     n = n + 1
    
46.                     err(n, 1) = brr(xstr, 1)        '"数据第" & xstr & "行：" & brr(xstr, 1)
    
47.                     err(n, 2) = "条件区间：第" & h & "行至第" & p & "行"
    
48.                     Cells(xstr + 2, 2).Interior.ColorIndex = n Mod 6 + 2
    
49.                     Range(Cells(h + 2, 3), Cells(p + 2, 3)).Interior.ColorIndex = n Mod 6 + 2
    
50.                     Exit For
    
51.                 End If
    
52.             Next
    
53.         Next
    
54.         If n > 0 Then [e13].Resize(n, 2) = err
    
55. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub grf()
   
2.     Cells.Interior.ColorIndex = 0
   
3.     [d3:d10000,e13:e1000].ClearContents
   
4.     brr = Range("b3:b" & [b65536].End(3).Row)
   
5.     crr = Range("c3:d" & [c65536].End(3).Row)
   
6.     ReDim drr(1 To UBound(crr), 1 To 1)
   
7.     ReDim err(1 To 1000, 1 To 2)
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.         For i = 1 To UBound(crr)
   
10.             tj = crr(i, 1)  '条件
    
11.             tj1 = Split(tj, "=")(0)
    
12.             xmin = Val(Split(tj1, "-")(0))
    
13.             xmax = Val(Split(tj1, "-")(1))
    
14.             tj2 = Split(tj, "=")(1)
    
15.             xrr = Split(tj2, " ")
    
16.             For Each x In xrr
    
17.                 d(x) = d(x) + 1
    
18.             Next
    
19.             For ii = 1 To UBound(brr)
    
20.                 xrr = Split(brr(ii, 1), " ")
    
21.                 s = 0
    
22.                 For Each x In xrr
    
23.                     If d.exists(x) Then s = s + 1
    
24.                 Next
    
25.                 If s >= xmin And s <= xmax Then drr(i, 1) = drr(i, 1) & "," & ii
    
26.             Next
    
27.             drr(i, 1) = Mid(drr(i, 1), 2)
    
28.             d.RemoveAll
    
29.         Next
    
30.         [d3].Resize(UBound(crr)) = drr    '第一步：得到drr，为crr中每个条件相符的brr中行号
    
31.         For h = 1 To UBound(crr) Step 20
    
32.             If UBound(crr) - h + 1 < 20 Then Exit For
    
33.             For p = h + 1 To h + 19      '从1：2行，到1：20行
    
34.                 d.RemoveAll:  zs = 0
    
35.                 For i = h To p
    
36.                     xrr = Split(drr(i, 1), ",")
    
37.                     For Each x In xrr
    
38.                         d(x) = d(x) + 1
    
39.                     Next
    
40.                 Next
    
41.                 For Each x In d.keys        'drr中h--p行某数出现的次数与行数相同，说明某数对应的brr数据与所有条件全符合
    
42.                     If d(x) = p - h + 1 Then zs = zs + 1: xstr = x
    
43.                 Next
    
44.                 If zs = 1 Then     '第二步：得到drr中组数为1的brr的行号
    
45.                     n = n + 1
    
46.                     err(n, 1) = brr(xstr, 1)        '"数据第" & xstr & "行：" & brr(xstr, 1)
    
47.                     err(n, 2) = "条件区间：第" & h & "行至第" & p & "行"
    
48.                     Cells(xstr + 2, 2).Interior.ColorIndex = n Mod 6 + 2
    
49.                     Range(Cells(h + 2, 3), Cells(p + 2, 3)).Interior.ColorIndex = n Mod 6 + 2
    
50.                     Exit For
    
51.                 End If
    
52.             Next
    
53.         Next
    
54.         If n > 0 Then [e13].Resize(n, 2) = err
    
55. End Sub

复制代码

grf1973

为清楚显示，把符合条件的数据行和条件区间用相同颜色作了标注。结果和楼主模拟的结果不同，请楼主自行测试。

rangevba

grf1973 发表于 2016-4-5 11:38

老师你好，程序经测试满足要求，而且速度很快，同我的结果是一样的，因为你把step设为20了题目要求是21，所以这二条改一下就全对了：
For h = 1 To UBound(crr) Step 21
If UBound(crr) - h + 1 < 21 Then Exit For
            For p = h + 1 To h + 20      '从1：2行，到1：20行


1、这个问题我用：1、函数加按钮，2、数组字典法写其二种方法的速度都不如老师的快，谢谢老师！
2、为了加快速度（实际运算b列的条件要到95万行）对于这个问题，目前我采用d列铺助行c列条件逐一提取逐一删除的方法：
1）、原题c列条件区间不变即每区间21行，以第1组c3:c23为例：首先c3对b列条件查找，符合c3条件的数据填在d3开始的d列，条件c4对d3开始的d列数据查找，符合c4条件的数据在删除原d3数据后填在d3开始的d列，依次进行直到d3的数据为1行，当d3的数据为1行时，停止查找并将d3列这1组数据依次填写在e3开始的e列各单元格同时转入下一组。
2）、如果区间到最大c3：c23 b列都没有符合条件1组的组数则转入下一组。

请老师有时间时按这个思路写写，特此谢谢！

grf1973

嗯，按你思路重编了一下。其中把BC列的比对作了个函数。

1. Dim d
   
2. Sub grf1()
   
3.     Cells.Interior.ColorIndex = 0
   
4.     [d3:d10000,e13:e1000].ClearContents
   
5.     brr = Range("b3:b" & [b65536].End(3).Row)
   
6.     crr = Range("c3:d" & [c65536].End(3).Row)
   
7.     ReDim drr(1 To UBound(crr), 1 To 1)
   
8.     ReDim err(1 To 1000, 1 To 2)
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     For i = 1 To UBound(crr) Step 21      '得到各组第一行满足条件的Brr行
    
11.         c = crr(i, 1)  '本行条件
    
12.         For ii = 1 To UBound(brr)
    
13.             b = brr(ii, 1)
    
14.             If ISOK(b, c) Then drr(i, 1) = drr(i, 1) & "," & ii
    
15.         Next
    
16.         
    
17.         For p = i To i + 20       '下20行，每一行从符合上一行条件的brr中筛选
    
18.             If p > UBound(crr) Then Exit For
    
19.             If p > i Then
    
20.                 c = crr(p, 1) '本行条件
    
21.                 xrr = Split(drr(p - 1, 1), ",")  '满足上一行条件的Brr
    
22.                 For Each x In xrr
    
23.                     b = brr(Val(x), 1)
    
24.                     If ISOK(b, c) Then drr(p, 1) = drr(p, 1) & "," & x: q = b: qq = x
    
25.                 Next
    
26.             End If
    
27.             drr(p, 1) = Mid(drr(p, 1), 2)
    
28.             If Len(drr(p, 1)) > 0 And InStr(drr(p, 1), ",") = 0 Then '满足条件的行数中不含“,”，说明只有一行
    
29.                 n = n + 1
    
30.                 err(n, 1) = q        '"数据第" & ii & "行：" & brr(xstr, 1)
    
31.                 err(n, 2) = "条件区间：第" & i & "行至第" & p & "行"
    
32.                 Cells(qq + 2, 2).Interior.ColorIndex = n Mod 6 + 2
    
33.                 Range(Cells(i + 2, 3), Cells(p + 2, 3)).Interior.ColorIndex = n Mod 6 + 2
    
34.                 Exit For
    
35.             End If
    
36.         Next
    
37.     Next
    
38.         
    
39.     [d3].Resize(UBound(crr)) = drr    '第一步：得到drr，为crr中每个条件相符的brr中行号
    
40.     If n > 0 Then [e13].Resize(n, 2) = err
    
41. End Sub
    
42. Function ISOK(b, c) As Boolean    'B列某行是否符合C列某行条件
    
43.    ' Set d = CreateObject("scripting.dictionary")
    
44.     d.RemoveAll
    
45.     tj1 = Split(c, "=")(0)          'c列条件
    
46.     xmin = Val(Split(tj1, "-")(0))
    
47.     xmax = Val(Split(tj1, "-")(1))
    
48.     tj2 = Split(c, "=")(1)
    
49.     xrr = Split(tj2, " ")
    
50.     For Each x In xrr
    
51.         d(x) = d(x) + 1
    
52.     Next
    
53.    
    
54.     xrr = Split(b, " ")
    
55.     For Each x In xrr
    
56.         If d.exists(x) Then s = s + 1
    
57.     Next
    
58.     If s >= xmin And s <= xmax Then ISOK = True
    
59. End Function

复制代码

grf1973

B列大数据量的话，提速效果要明显得多。

rangevba

grf1973 发表于 2016-4-6 11:04
B列大数据量的话，提速效果要明显得多。

老师你好，程序经测试满足要求，我弄了大半个月的东西，老师终于帮我解决了，谢谢，谢谢！！！

rangevba

grf1973 发表于 2016-4-6 11:04
B列大数据量的话，提速效果要明显得多。

谢谢老师！

rangevba

grf1973 发表于 2016-4-6 11:03
嗯，按你思路重编了一下。其中把BC列的比对作了个函数。

老师你好，本程序在运行过程中很稳定，为了加快运行速度，请老师再修改一下，谢谢！

1、各大组中，首先一次求出同时满足c列前12条的b列数据，从第13条开始对同时满足c列前12条的b列数据过滤并提取符合条件的数据，第14条开始对同时满足c13的b列数据过滤提取符合条件的数据，依次......

2、如第一组：c3-c23,首先一次求出同时满足c3-c14共12条条件的b列数据，c15开始对同时满足c3-c14共12条条件的b列数据过滤并提取符合条件的数据，c16条开始对同时满足c15的b列数据过滤提取符合条件的数据，依次......

3、就是将各组21条条件分成2个部分，前12条一次求出，后9条作为微条数据逐一对前1条数据过滤并提取符合条件的数据，这样其运行速度比单条逐一过滤提高20倍，请老师有时间时修改一下，谢谢！

grf1973

目前的数据量看不出速度区别。

1. Sub grf_2()     '先一次找满足各组前12条的b列数据，再从13条开始
   
2.     tt = Timer
   
3.     Cells.Interior.ColorIndex = 0
   
4.     [d3:d10000,e13:e1000].ClearContents
   
5.     brr = Range("b3:b" & [b65536].End(3).Row)
   
6.     crr = Range("c3:d" & [c65536].End(3).Row)
   
7.     ReDim drr(1 To UBound(crr), 1 To 1)
   
8.     ReDim err(1 To 1000, 1 To 2)
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     For ii = 1 To UBound(brr)
    
11.         b = brr(ii, 1)
    
12.         For i = 1 To UBound(crr) Step 21      '各组第一行为i
    
13.             For k = 0 To 11    '各组前12行
    
14.                 c = crr(i + k, 1) '本行条件
    
15.                 If Not ISOK(b, c) Then Exit For
    
16.             Next
    
17.             If k = 12 Then drr(i + 11, 1) = drr(i + 11, 1) & "," & ii
    
18.         Next
    
19.     Next
    
20.     For i = 1 To UBound(crr) Step 21      '各组第一行为i
    
21.         For p = i + 11 To i + 20     '从13行开始到21行，每一行从符合上一行条件的brr中筛选(12行一并检查）
    
22.             If p > UBound(crr) Then Exit For
    
23.             If p > i + 11 Then      '从13行开始到21行
    
24.                 c = crr(p, 1) '本行条件
    
25.                 xrr = Split(drr(p - 1, 1), ",")  '满足上一行条件的Brr
    
26.                 For Each x In xrr
    
27.                     b = brr(Val(x), 1)
    
28.                     If ISOK(b, c) Then drr(p, 1) = drr(p, 1) & "," & x
    
29.                 Next
    
30.             End If
    
31.             
    
32.             drr(p, 1) = Mid(drr(p, 1), 2)
    
33.             If Len(drr(p, 1)) = 0 Then Exit For
    
34.             If Len(drr(p, 1)) > 0 And InStr(drr(p, 1), ",") = 0 Then '满足条件的行数中不含“,”，说明只有一行
    
35.                 qq = drr(p, 1): q = brr(qq, 1):
    
36.                 n = n + 1
    
37.                 err(n, 1) = q        '"数据第" & ii & "行：" & brr(xstr, 1)
    
38.                 err(n, 2) = "条件区间：第" & i & "行至第" & p & "行"
    
39.                 Cells(qq + 2, 2).Interior.ColorIndex = n Mod 6 + 2
    
40.                 Range(Cells(i + 2, 3), Cells(p + 2, 3)).Interior.ColorIndex = n Mod 6 + 2
    
41.                 Exit For
    
42.             End If
    
43.         Next
    
44.     Next
    
45.         
    
46.     [d3].Resize(UBound(crr)) = drr
    
47.     If n > 0 Then [e13].Resize(n, 2) = err
    
48.     MsgBox Timer - tt
    
49. End Sub

复制代码