求将同时符合c列3个条件的b列数组提取到d列的vba程序

[pcaonib]

求大侠在百忙中帮我写个：将同时符合c列3个条件的b列数组提取到d列的vba程序，先谢谢了！

1、b5开始的b列各单元格分别填有不同的数组且每2个数字间空1格。
2、c5开始的c列各单元格分别填有不同的条件数据，以等号为界，等号右边数字每2个数字间空1格,等号左边为条件，表示右边的数字包含多少个数据。

如：
1-2=3 8 15 21 23 表示在：3 8 15 2123 这5个数中选择1到2（或1个或2个）个。
0-3=4 12 15 20 33 35 36 表示在：4 12 1520 33 35 36 这7个数中选择0到3（或0或1或2或3个）个。
1-3=1 10 22 25 26 33 表示在：1 10 2225 26 这6个数中选择1到3（或1或2或3个）个。
3、c5开始的c列，每行为一个条件每3行为1组，即c5、c6、c7为第1组，c8、c9、c10为第2组，c11、c12、c13为第3组。。。。。。
4、点击按钮后c5开始的c列各组3个条件依次分别对b5开始的b列各单元格的所有数字进行查找，同时符合各组3个条件的b列数组就被依次提取并依次填写在d5开始的d列各单元格，即点击按钮后首先第1组条件开始查找，第1组条件查找完并提取数字后再接着第2组开始查找，第2组条件查找完并提取数字后再接着第3组开始查找，特别注意的是：第2组条件提取出来的数字接在第1组条件提取出来的数字的后面，依次类推。

如：
c5单元格：1-2=4 916 19 21 23 31
c6单元格：1-2=3 6 711 14 20 36
c7单元格：1-2=2 511 15 19 22 36
为第1组，点击按钮后这组条件就开始对b5开始的b列各单元格的数字查找，那么同时符合这3条件的数组就被提取，经查找b列中下面这3组数据都能同时满足3个条件，因而程序运行后b列中的这3条数组就被依次提取到d5开始的d栏中:
2 20 25 27 31 34 36
7 13 15 20 21 26 30
3 15 18 19 21 27 28

为什么说上面3条能同时满足3个条件呢，以最后一条：3 15 18 19 21 27 28 为例说明：
3 15 18 19 21 27 28 对于第1个条件：1-2=4 916 19 21 23 31,包含的数是：19 21，共2个数而条件是1到2个（1个或2个），符合第1个条件。
3 15 18 19 21 27 28对于第2个条件：1-2=3 6 711 14 20 36,包含的数是：3，共1个数而条件是1到2个（1个或2个），符合第2个条件。
3 15 18 19 21 27 28 对于第3个条件：1-2=2 511 15 19 22 36,包含的数是：15 19，共2个而条件是1到2个（1个或2个），符合第1个条件。那么这一条就同时满足了3个条件，则这一数组符合条件被提取到d5开始的d栏中。
谢谢！

[Treenewbee]

又见彩票。 难度不是很大，只是太耗时了。

[fjmqfsl]

下面是VBA代码，将你的按钮指定宏为“筛选”，下面还有一个代码是自动生10000组随机生成7个1至36的数字 Sub 筛选() Dim tt As String Dim ma, mi, tj, dn, pd As Long Dim nn As Double Dim brr Set d = CreateObject("scripting.dictionary") arr = Range("c5:c" & Range("c65536").End(3).Row) crr = Range("b5:b" & Range("b65536").End(3).Row) Dim drr() For i = 1 To UBound(arr) n = n + 1 tt = Mid(arr(i, 1), 5, 100) brr = Split(tt, " ") mi = CSng(Mid(arr(i, 1), 1, 1)) ma = CSng(Mid(arr(i, 1), 3, 1)) nn = Rnd() tj = Round(nn * (ma - mi) + mi, 0) For j = 1 To tj d(brr(Round(Rnd() * UBound(brr), 0))) = i Next If n = 3 Then For j = 1 To UBound(crr) brr = Split(crr(j, 1), " ") pd = 0 For k = 0 To UBound(brr) If d.exists(brr(k)) Then pd = pd + 1 Next If pd = d.Count Then dn = dn + 1 ReDim Preserve drr(1 To dn) drr(dn) = crr(j, 1) End If Next n = 0 d.RemoveAll End If Next Range("e5:e" & Range("e65536").End(3).Row) = Empty If dn > 0 Then [e5].Resize(UBound(drr), 1) = Application.Transpose(drr) End Sub Sub 随机生成10000组() Set d = CreateObject("scripting.dictionary") Dim arr(1 To 10000, 1 To 1) For i = 1 To 10000 For j = 1 To 36 tt = Round(Rnd() * 36 + 1, 0) n = 0 n = n + 1 If Not d.exists(tt) Then d(tt) = tt: strr = strr & tt & " " If d.Count = 7 Then strr = Mid(strr, 1, Len(strr) - 1): Exit For Next arr(i, 1) = strr d.RemoveAll strr = "" Next [g1].Resize(10000, 1) = arr End Sub

[fjmqfsl]

操作一次不一定能有结果（好象没有反映），但多操作几次一定会有结果的，因为随机生成的条件不一样，结果有不一样，有可能会是0记录。

[fjmqfsl]

还要注意的是： 要把代码放在你数据所在表的模块里，因为我不知道的的数据是在哪一张表里，所在没有表引用的表达代码。

[pcaonib]

条件是指定的而不是随机生成的，用指定c列的条件对b列数据过滤，最后提取符合条件的数据，请将条件改为固定，谢谢！

[pcaonib]

经测试，当条件为3条时其结果是对的，但是我把条件改为每30条一组时，Case 不就要写Case 1到Case 30对吗？而If pd1 >= mi1 And pd1 <= ma1 And pd2 >= mi2 And pd2 <= ma2 And pd3 >= mi3 And pd3 <= ma3 也要有30个比较对吗？要是这2点能进一步修改一下程序就相当完善了，因为我实际用到的可能是20个条件一组，也可能是30个条件一组.也可能是80个条件一组.这点会经常改变，希望你在这方面修改一下，以便程序好修改，谢谢！

[fjmqfsl]

条件C列每一行的数字都是7个吗？

[fjmqfsl]

如果条件C列每一行的数字都是7个的话，这个代码可以用。 Sub 筛选() Dim tt As String Dim tj, dn, pd As Long Dim brr Set d = CreateObject("scripting.dictionary") arr = Range("c5:c" & Range("c65536").End(3).Row) crr = Range("b5:b" & Range("b65536").End(3).Row) Dim drr() Dim tjrr() tj = CSng(InputBox("请输入条件数:", "请输入条件数", 3)) ReDim tjrr(1 To tj, 1 To 9) For i = 1 To UBound(arr) n = n + 1 tt = Mid(arr(i, 1), 5, 100) brr = Split(tt, " ") tjrr(n, 1) = Mid(arr(i, 1), 1, 1) tjrr(n, 2) = Mid(arr(i, 1), 3, 1) For j = 0 To UBound(brr) tjrr(n, j + 3) = brr(j) Next If n = tj Then For j = 1 To UBound(crr) brr = Split(crr(j, 1), " ") For k = 1 To tj pd = 0 For l = 3 To 9 d(tjrr(k, l)) = j Next For l = 0 To UBound(brr) If d.exists(brr(l)) Then pd = pd + 1 Next d.RemoveAll If pd < CSng(tjrr(k, 1)) Or pd > CSng(tjrr(k, 2)) Then Exit For Next If k = tj + 1 Then dn = dn + 1: ReDim Preserve drr(1 To dn): drr(dn) = crr(j, 1) Next ReDim tjrr(1 To tj, 1 To 9) n = 0 End If Next Range("d5:d" & Range("d65536").End(3).Row) = Empty If dn > 0 Then [d5].Resize(UBound(drr), 1) = Application.Transpose(drr) End Sub

[pcaonib]

经测试条件C列每一行的数字都是7个的话，结果是对的，非常感谢你写出这么专业的代码，谢谢！

[fjmqfsl]

Sub 筛选() Dim tt As String Dim ma1, mi1, ma2, mi2, ma3, mi3, tj, dn, pd1, pd2, pd3 As Long Dim nn As Double Dim brr Set d1 = CreateObject("scripting.dictionary") Set d2 = CreateObject("scripting.dictionary") Set d3 = CreateObject("scripting.dictionary") arr = Range("c5:c" & Range("c65536").End(3).Row) crr = Range("b5:b" & Range("b65536").End(3).Row) Dim drr() For i = 1 To UBound(arr) n = n + 1 tt = Mid(arr(i, 1), 5, 100) brr = Split(tt, " ") If n = 1 Then mi1 = CSng(Mid(arr(i, 1), 1, 1)) If n = 1 Then ma1 = CSng(Mid(arr(i, 1), 3, 1)) If n = 2 Then mi2 = CSng(Mid(arr(i, 1), 1, 1)) If n = 2 Then ma2 = CSng(Mid(arr(i, 1), 3, 1)) If n = 3 Then mi3 = CSng(Mid(arr(i, 1), 1, 1)) If n = 3 Then ma3 = CSng(Mid(arr(i, 1), 3, 1)) 'nn = Rnd() 'tj = Round(nn * (ma - mi) + mi, 0) Select Case n Case 1 For j = 0 To UBound(brr) d1(brr(j)) = i Next Case 2 For j = 0 To UBound(brr) d2(brr(j)) = i Next Case 3 For j = 0 To UBound(brr) d3(brr(j)) = i Next End Select If n = 3 Then For j = 1 To UBound(crr) brr = Split(crr(j, 1), " ") pd1 = 0: pd2 = 0: pd3 = 0 For k = 0 To UBound(brr) If d1.exists(brr(k)) Then pd1 = pd1 + 1 If d2.exists(brr(k)) Then pd2 = pd2 + 1 If d3.exists(brr(k)) Then pd3 = pd3 + 1 Next If pd1 >= mi1 And pd1 <= ma1 And pd2 >= mi2 And pd2 <= ma2 And pd3 >= mi3 And pd3 <= ma3 Then dn = dn + 1 ReDim Preserve drr(1 To dn) drr(dn) = crr(j, 1) End If Next n = 0 d1.RemoveAll d2.RemoveAll d3.RemoveAll End If Next Range("d5:d" & Range("d65536").End(3).Row) = Empty If dn > 0 Then [d5].Resize(UBound(drr), 1) = Application.Transpose(drr) End Sub

[fjmqfsl]

简化如下： Sub 筛选() Dim tt As String Dim ma1, mi1, ma2, mi2, ma3, mi3, tj, dn, pd1, pd2, pd3 As Long Dim nn As Double Dim brr Set d1 = CreateObject("scripting.dictionary") Set d2 = CreateObject("scripting.dictionary") Set d3 = CreateObject("scripting.dictionary") arr = Range("c5:c" & Range("c65536").End(3).Row) crr = Range("b5:b" & Range("b65536").End(3).Row) Dim drr() For i = 1 To UBound(arr) n = n + 1 tt = Mid(arr(i, 1), 5, 100) brr = Split(tt, " ") Select Case n Case 1 mi1 = CSng(Mid(arr(i, 1), 1, 1)): ma1 = CSng(Mid(arr(i, 1), 3, 1)) For j = 0 To UBound(brr) d1(brr(j)) = i Next Case 2 mi2 = CSng(Mid(arr(i, 1), 1, 1)): ma2 = CSng(Mid(arr(i, 1), 3, 1)) For j = 0 To UBound(brr) d2(brr(j)) = i Next Case 3 mi3 = CSng(Mid(arr(i, 1), 1, 1)): ma3 = CSng(Mid(arr(i, 1), 3, 1)) For j = 0 To UBound(brr) d3(brr(j)) = i Next End Select If n = 3 Then For j = 1 To UBound(crr) brr = Split(crr(j, 1), " ") pd1 = 0: pd2 = 0: pd3 = 0 For k = 0 To UBound(brr) If d1.exists(brr(k)) Then pd1 = pd1 + 1 If d2.exists(brr(k)) Then pd2 = pd2 + 1 If d3.exists(brr(k)) Then pd3 = pd3 + 1 Next If pd1 >= mi1 And pd1 <= ma1 And pd2 >= mi2 And pd2 <= ma2 And pd3 >= mi3 And pd3 <= ma3 Then dn = dn + 1 ReDim Preserve drr(1 To dn) drr(dn) = crr(j, 1) End If Next n = 0 d1.RemoveAll d2.RemoveAll d3.RemoveAll End If Next Range("d5:d" & Range("d65536").End(3).Row) = Empty If dn > 0 Then [d5].Resize(UBound(drr), 1) = Application.Transpose(drr) End Sub