[已解决]EXCEL高手用VBA做两个条件

grf1973

1. Sub main()
   
2.     tms = Timer
   
3.     arr = [c17:h37]       '彩票数据数组
   
4.     brr = [j12:u15]        '条件数组
   
5.     ReDim crr(1 To UBound(arr), 1 To UBound(brr, 2))       '结果数组
   
6.     Dim ar%(1 To 6), br%(1 To 3)
   
7.     For i = 1 To UBound(arr)
   
8.         For k = 1 To 6: ar(k) = arr(i, k): Next
   
9.         For j = 1 To UBound(brr, 2)
   
10.             br(1) = brr(1, j): br(2) = brr(2, j): br(3) = brr(3, j)
    
11.             p = CompAB(ar, br)
    
12.             If p > 0 Then crr(i, j) = brr(4, j)
    
13.         Next
    
14.     Next
    
15.     [J17].Resize(UBound(crr), UBound(crr, 2)) = crr
    
16.    
    
17.     For j = 1 To UBound(crr, 2)        '判断连续出现的最大次数
    
18.         smax = 0
    
19.         For i = 1 To UBound(crr)
    
20.             If crr(i, j) = "" Then s = 0 Else s = s + 1
    
21.             If s > smax Then smax = s
    
22.         Next
    
23.         Cells(5, j + 9) = smax & "次"
    
24.     Next
    
25.    
    
26.     MsgBox Timer - tms & "秒"
    
27. End Sub
    
28. 
    
29. Function CompAB(ar%(), br%())        '返回数组br各数在数组ar中出现的次数
    
30.     Dim s%(1 To 33)
    
31.     For Each a In ar    '数组s以ar中每个数为下标的值设为1
    
32.         If a > 0 Then s(a) = 1
    
33.     Next
    
34.     For Each b In br       '数组s以br中每个数为下标的值相加，即为数组br各数在数组ar中出现的次数
    
35.         If b > 0 Then CompAB = CompAB + s(b)
    
36.     Next
    
37. End Function
    

复制代码

grf1973

请看附件。以前做的那个数组比较的函数能用到此例中。

grf1973

主程序代码还可简化。

1. Sub main()
   
2.     tms = Timer
   
3.     arr = [c17:h37]       '彩票数据数组
   
4.     brr = [j12:u15]        '条件数组
   
5.     ReDim crr(1 To UBound(arr), 1 To UBound(brr, 2))       '结果数组
   
6.     Dim ar%(1 To 6), br%(1 To 3)
   
7.     For j = 1 To UBound(brr, 2)
   
8.         smax = 0
   
9.         br(1) = brr(1, j): br(2) = brr(2, j): br(3) = brr(3, j)
   
10.         For i = 1 To UBound(arr)
    
11.             For k = 1 To 6: ar(k) = arr(i, k): Next
    
12.             p = CompAB(ar, br)
    
13.             If p > 0 Then crr(i, j) = brr(4, j): s = s + 1 Else s = 0
    
14.             If s > smax Then smax = s
    
15.         Next
    
16.         Cells(5, j + 9) = smax & "次"
    
17.     Next
    
18.     [J17].Resize(UBound(crr), UBound(crr, 2)) = crr
    
19.     MsgBox Timer - tms & "秒"
    
20. End Sub

复制代码

grf1973

继续简化，不用子程序，一个主程序解决。

1. Sub main()
   
2.     tms = Timer
   
3.     arr = [c17:h37]       '彩票数据数组
   
4.     brr = [j12:u15]        '条件数组
   
5.     ReDim crr(1 To UBound(arr), 1 To UBound(brr, 2))       '结果数组
   
6.     For j = 1 To UBound(brr, 2)
   
7.         smax = 0
   
8.         For i = 1 To UBound(arr)
   
9.             xstr = "," & Join(Application.Index(arr, i), ",") & ","
   
10.             If InStr(xstr, "," & brr(1, j) & ",") > 0 Or InStr(xstr, "," & brr(2, j) & ",") > 0 _
    
11.                 Or InStr(xstr, "," & brr(3, j) & ",") > 0 Then crr(i, j) = brr(4, j): s = s + 1 Else s = 0
    
12.             If s > smax Then smax = s
    
13.         Next
    
14.         Cells(5, j + 9) = smax & "次"
    
15.     Next
    
16.     [J17].Resize(UBound(crr), UBound(crr, 2)) = crr
    
17.     MsgBox Timer - tms & "秒"
    
18. End Sub

复制代码