[已解决]求符合c5、c6二个单元格数据条件的b列数字的vba

rangevba

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

2、c5、c6单元格填有条件数据，以等号为界，等号右边数字每2个数字间空1格,等号左边为区间条件，表示等号右边的数据与b列某个单元格数据个数相同的数据个数。
  如c5条件：
  1-2=3 8 15 21 23          表示在：3 8 15 21 23     这5个数中有1到2个数据与b列某个单元格有1到2个数据相同（也就是大家都有的数据）。

3、点击按钮后，c5、c6单元格的数字对b5开始的b列各单元格的所有数字进行查找，同时符合c5、c6二个单元格数据条件的b5开始的b列各单元格数字依次提取到e5开始的e列各单元格.

4、本题要解决的关键问提是：输出结果大于10万行时不出问题即能正常输出到e5开始的e列（当然本题的结果不会大于10万行）。


谢谢！


提取数据.zip (15.78 KB, 下载次数: 9)

2016-4-9 18:28 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2016-4-9 19:35

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, k&
   
3. arr = [b5:b14]
   
4. brr = [c5:c6]
   
5. n = UBound(brr): [e:e] = ""
   
6. ReDim crr(1 To UBound(arr), 1 To 1)
   
7. redim d(1  to n)
   
8. ReDim w(1 To n, 1 To 2) '存放条件中相同数据起止值
   
9. For i = 1 To n
   
10.     Set d(i) = CreateObject("scripting.dictionary")
    
11.     x = Split(brr(i, 1), "=")
    
12.     h = Split(x(1)) '等号后部分
    
13.     For j = 0 To UBound(h)
    
14.         d(i)(h(j)) = ""
    
15.     Next
    
16.     q = Split(x(0), "-") '等号前部分
    
17.     w(i, 1) = Val(q(0)): w(i, 2) = Val(q(1))
    
18. Next
    
19. For i = 1 To UBound(arr)
    
20.     x = Split(arr(i, 1))
    
21.     For k = 1 To n
    
22.         s = 0
    
23.         For j = 0 To UBound(x)
    
24.             If d(k).exists(x(j)) Then s = s + 1
    
25.         Next
    
26.         If s >= w(k, 1) And s <= w(k, 2) Then crr(i, 1) = crr(i, 1) + 1
    
27.     Next
    
28. Next
    
29. m = 4
    
30. For i = 1 To UBound(crr)
    
31.     If crr(i, 1) = n Then m = m + 1: Cells(m, 5) = arr(i, 1)
    
32. Next
    
33. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, k&
   
3. arr = [b5:b14]
   
4. brr = [c5:c6]
   
5. n = UBound(brr): [e:e] = ""
   
6. ReDim crr(1 To UBound(arr), 1 To 1)
   
7. redim d(1  to n)
   
8. ReDim w(1 To n, 1 To 2) '存放条件中相同数据起止值
   
9. For i = 1 To n
   
10.     Set d(i) = CreateObject("scripting.dictionary")
    
11.     x = Split(brr(i, 1), "=")
    
12.     h = Split(x(1)) '等号后部分
    
13.     For j = 0 To UBound(h)
    
14.         d(i)(h(j)) = ""
    
15.     Next
    
16.     q = Split(x(0), "-") '等号前部分
    
17.     w(i, 1) = Val(q(0)): w(i, 2) = Val(q(1))
    
18. Next
    
19. For i = 1 To UBound(arr)
    
20.     x = Split(arr(i, 1))
    
21.     For k = 1 To n
    
22.         s = 0
    
23.         For j = 0 To UBound(x)
    
24.             If d(k).exists(x(j)) Then s = s + 1
    
25.         Next
    
26.         If s >= w(k, 1) And s <= w(k, 2) Then crr(i, 1) = crr(i, 1) + 1
    
27.     Next
    
28. Next
    
29. m = 4
    
30. For i = 1 To UBound(crr)
    
31.     If crr(i, 1) = n Then m = m + 1: Cells(m, 5) = arr(i, 1)
    
32. Next
    
33. End Sub

复制代码

dsmch

条件可以增加行

rangevba

dsmch 发表于 2016-4-9 19:36
条件可以增加行

老师你好，程序经反复测试满足要求，b列数据90万行，c列条件6行，用时33秒，得到符合条件的数据21万行，完全满足要求，谢谢!

rangevba

dsmch 发表于 2016-4-9 19:35

老师你好，就本题而言：其他条件不变，只增大查找数据的列数，原来在b列中查找，现改为在a、b二列数据中查找即：


点击按钮后，c5、c6、c7单元格的数字对a5开始的a列各单元格的所有数字及b5开始的b列各单元格的所有数字进行查找，同时符合c5、c6、c7三个单元格数据条件的a5、b5开始的各列单元格数字依次提取到e5开始的e列各单元格.

麻烦老师有时间修改一下，谢谢！

区域数据.zip (6.76 KB, 下载次数: 8)

2016-4-10 17:42 上传

点击文件名下载附件

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, k&
   
3. brr = [c5:c7]
   
4. n = UBound(brr): [e:e] = ""
   
5. ReDim d(1 To n)
   
6. ReDim w(1 To n, 1 To 2) '存放条件中相同数据起止值
   
7. For i = 1 To n
   
8.     Set d(i) = CreateObject("scripting.dictionary")
   
9.     x = Split(brr(i, 1), "=")
   
10.     h = Split(x(1)) '等号后部分
    
11.     For j = 0 To UBound(h)
    
12.         d(i)(h(j)) = ""
    
13.     Next
    
14.     q = Split(x(0), "-") '等号前部分
    
15.     w(i, 1) = Val(q(0)): w(i, 2) = Val(q(1))
    
16. Next
    
17. hh = 5
    
18. For kk = 1 To 2
    
19. r = Cells(Rows.Count, kk).End(xlUp).Row
    
20. arr = Range(Cells(5, kk), Cells(r, kk))
    
21. ReDim crr(1 To UBound(arr), 1 To 1)
    
22. For i = 1 To UBound(arr)
    
23.     x = Split(arr(i, 1))
    
24.     For k = 1 To n
    
25.         s = 0
    
26.         For j = 0 To UBound(x)
    
27.             If d(k).exists(x(j)) Then s = s + 1
    
28.         Next
    
29.         If s >= w(k, 1) And s <= w(k, 2) Then crr(i, 1) = crr(i, 1) + 1
    
30.     Next
    
31. Next
    
32. m = 0
    
33. For i = 1 To UBound(crr)
    
34.     If crr(i, 1) = n Then m = m + 1: crr(m, 1) = arr(i, 1)
    
35. Next
    
36. If m = 1 Then Cells(hh, 5) = crr(1, 1)
    
37. If m > 1 Then Cells(hh, 5).Resize(m) = crr
    
38. hh = Cells(Rows.Count, 5).End(xlUp).Row + 1
    
39. Next
    
40. End Sub

复制代码

rangevba

dsmch 发表于 2016-4-10 19:35

老师你好，程序经反复测试满足要求，我搞了一整天都没有收获，老师真厉害，谢谢！

rangevba

dsmch 发表于 2016-4-9 19:35

老师你好，我想将本程序的运行结果固定为1条，条件数即c列数据固定在c5:c14,
1、程序先运行c5:c7并将同时符合3个条件的结果存放在数组arr,如果arr的组数等于1时停止查找，并将数字依次提取到e5开始的e列各单元格
2、如果arr的组数大于1时，就用c8条件在arr数组中提取符合条件c8的数据并存放在数组arr1中，如果arr1的组数大于1时，就用c9条件在arr1数组中提取符合条件c9的数据并存放在数组arr2中，条件每次增加1个单元格最大增大到c14直到组数为1组时停止查找。

请老师有时间时出手相助，谢谢！