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

pcaonib 2014-01-11 07:53:47
求大侠在百忙中帮我写个:将同时符合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栏中。
谢谢!
...全文
229 点赞 收藏 11
写回复
11 条回复
fjmqfsl 2014年01月20日
简化如下: 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
回复 点赞
fjmqfsl 2014年01月20日
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
回复 点赞
pcaonib 2014年01月20日
经测试条件C列每一行的数字都是7个的话,结果是对的,非常感谢你写出这么专业的代码,谢谢!
回复 点赞
fjmqfsl 2014年01月20日
如果条件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
回复 点赞
fjmqfsl 2014年01月20日
条件C列每一行的数字都是7个吗?
回复 点赞
pcaonib 2014年01月20日
经测试,当条件为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个条件一组.这点会经常改变,希望你在这方面修改一下,以便程序好修改,谢谢!
回复 点赞
pcaonib 2014年01月18日
条件是指定的而不是随机生成的,用指定c列的条件对b列数据过滤,最后提取符合条件的数据,请将条件改为固定,谢谢!
回复 点赞
fjmqfsl 2014年01月17日
还要注意的是: 要把代码放在你数据所在表的模块里,因为我不知道的的数据是在哪一张表里,所在没有表引用的表达代码。
回复 点赞
fjmqfsl 2014年01月17日
操作一次不一定能有结果(好象没有反映),但多操作几次一定会有结果的,因为随机生成的条件不一样,结果有不一样,有可能会是0记录。
回复 点赞
fjmqfsl 2014年01月17日
下面是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
回复 点赞
Treenewbee 2014年01月16日
又见彩票。 难度不是很大,只是太耗时了。
回复 点赞
发动态
发帖子
VBA
创建于2007-09-28

1576

社区成员

1.0w+

社区内容

VBA(Visual Basic for Applications)是Visual Basic的一种宏语言,是在其桌面应用程序中执行通用的自动化(OLE)任务的编程语言。
社区公告
暂无公告