[已解决]请问这段代码如何改？？？？？？

hanjia

多加一段后就循环了
能不能合到一起？

Sub Macro1()
Dim arr, brr, i&, j%, k%
arr = Range("a1:f" & Range("a65536").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To 1)
w = Array(1, 2, 5, 8)
For i = 2 To UBound(arr)
    s = 0
    For j = 1 To UBound(arr, 2)
        For k = 0 To UBound(w)
            If arr(i, j) = w(k) Then s = s + 1
        Next
        If s >= 3 Then brr(i, 1) = 0: Exit For
    Next
    If s < 3 Then brr(i, 1) = brr(i - 1, 1) + 1
Next
Range("h1").Resize(UBound(brr)) = brr
arr = Range("a1:f" & Range("a65536").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To 1)
w = Array(1, 3, 6, 7)
For i = 2 To UBound(arr)
    s = 0
    For j = 1 To UBound(arr, 2)
        For k = 0 To UBound(w)
            If arr(i, j) = w(k) Then s = s + 1
        Next
        If s >= 3 Then brr(i, 1) = 0: Exit For
    Next
    If s < 3 Then brr(i, 1) = brr(i - 1, 1) + 1
Next
Range("i1").Resize(UBound(brr)) = brr
End Sub

工作表1.zip (14.31 KB, 下载次数: 5)

2016-7-9 12:32 上传

点击文件名下载附件

比如像下面这样直接加进去呢  
   这样他只查找(1, 3, 6, 7)这条
(1, 2, 5, 8)这条就被忽略了   H列和I列显示出来就一样了

Sub Macro1()
Dim arr, brr, i&, j%, k%
arr = Range("a1:f" & Range("a65536").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To 1)
w = Array(1, 2, 5, 8)
w = Array(1, 3, 6, 7)
For i = 2 To UBound(arr)
    s = 0
    For j = 1 To UBound(arr, 2)
        For k = 0 To UBound(w)
            If arr(i, j) = w(k) Then s = s + 1
        Next
        If s >= 3 Then brr(i, 1) = 0: Exit For
    Next
    If s < 3 Then brr(i, 1) = brr(i - 1, 1) + 1
Next
Range("h1").Resize(UBound(brr)) = brr
Range("i1").Resize(UBound(brr)) = brr
End Sub

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-7-9 16:14

1. Sub Macro1x()
   
2. Dim arr, brr, i&, j%, k%
   
3. arr = Range("a1:f" & Range("a65536").End(xlUp).Row)
   
4. ReDim brr(1 To UBound(arr), 1 To 1)
   
5. '下面一行代码可以一直新增，注意数组放在Array()中
   
6. w = Array(Array(1, 2, 6, 9), Array(1, 5, 6, 8), Array(3, 5, 6, 10))
   
7. For x = 0 To UBound(w)
   
8.     For i = 2 To UBound(arr)
   
9.         s = 0
   
10.         For j = 1 To UBound(arr, 2)
    
11.             For k = 0 To UBound(w(x))
    
12.                 If arr(i, j) = w(x)(k) Then s = s + 1
    
13.             Next
    
14.             If s >= 3 Then brr(i, 1) = 0: Exit For
    
15.         Next
    
16.         If s < 3 Then brr(i, 1) = brr(i - 1, 1) + 1
    
17.     Next
    
18.     Range("j1").Offset(0, x).Resize(UBound(brr)) = brr
    
19. Next
    
20. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

不知道是不是这个意思：

1. Sub Macro11()
   
2. Dim arr, brr, i&, j%, k%, crr, k1%
   
3. arr = Range("a1:f" & Range("a65536").End(xlUp).Row)
   
4. ReDim brr(1 To UBound(arr), 1 To 1)
   
5. ReDim crr(1 To UBound(arr), 1 To 1)
   
6. w = Array(1, 2, 6, 9)
   
7. w1 = Array(1, 5, 6, 8)
   
8. For i = 2 To UBound(arr)
   
9.     s = 0
   
10.     s1 = 0
    
11.     For j = 1 To UBound(arr, 2)
    
12.         For k = 0 To UBound(w)
    
13.             If arr(i, j) = w(k) Then s = s + 1
    
14.         Next
    
15.         If s >= 3 Then brr(i, 1) = 0
    
16.         For k1 = 0 To UBound(w1)
    
17.             If arr(i, j) = w1(k1) Then s1 = s1 + 1
    
18.         Next
    
19.         If s1 >= 3 Then crr(i, 1) = 0
    
20.     Next
    
21.     If s < 3 Then brr(i, 1) = brr(i - 1, 1) + 1
    
22.     If s1 < 3 Then crr(i, 1) = crr(i - 1, 1) + 1
    
23. Next
    
24. Range("j1").Resize(UBound(brr)) = brr
    
25. Range("k1").Resize(UBound(brr)) = crr
    
26. End Sub

复制代码

hanjia

老司机带带我 发表于 2016-7-9 13:25
不知道是不是这个意思：

先谢谢再说
还能再精简点吗？ 因为不只这2组
刚才试了往里再增加   弄了半天都加不上
现在是前面2组  我要往里增加应该改那里？
(1, 2, 6, 9)
(1, 5, 6, 8)
(3, 5, 6, 10)

老司机带带我

1. Sub Macro1x()
   
2. Dim arr, brr, i&, j%, k%
   
3. arr = Range("a1:f" & Range("a65536").End(xlUp).Row)
   
4. ReDim brr(1 To UBound(arr), 1 To 1)
   
5. '下面一行代码可以一直新增，注意数组放在Array()中
   
6. w = Array(Array(1, 2, 6, 9), Array(1, 5, 6, 8), Array(3, 5, 6, 10))
   
7. For x = 0 To UBound(w)
   
8.     For i = 2 To UBound(arr)
   
9.         s = 0
   
10.         For j = 1 To UBound(arr, 2)
    
11.             For k = 0 To UBound(w(x))
    
12.                 If arr(i, j) = w(x)(k) Then s = s + 1
    
13.             Next
    
14.             If s >= 3 Then brr(i, 1) = 0: Exit For
    
15.         Next
    
16.         If s < 3 Then brr(i, 1) = brr(i - 1, 1) + 1
    
17.     Next
    
18.     Range("j1").Offset(0, x).Resize(UBound(brr)) = brr
    
19. Next
    
20. End Sub

复制代码

hanjia

老司机带带我 发表于 2016-7-9 16:14

我在后面多加一组  提示  编译错误:   缺少: 语句结束
w = Array(Array(1, 2, 6, 9), Array(1, 5, 6, 8), Array(3, 5, 6, 10))
w = Array(Array(1, 2, 6, 9), Array(1, 5, 6, 8), Array(3, 5, 6, 10)), Array(4, 7, 8, 11))

hanjia

老司机带带我 发表于 2016-7-9 16:14

明白了   要在 )) 前面加才可以   
谢谢     这简单多了   谢谢

hanjia

老司机带带我 发表于 2016-7-9 16:14

w = Array(Array(1, 2, 6, 9), Array(1, 5, 6, 8), Array(3, 5, 6, 10)), Array(4, 7, 8, 11))
加多了提示 法语错误
我重新发了个求助 有空帮忙再看一下  谢谢
http://www.excelpx.com/thread-419789-1-1.html

工作表2.zip (12.79 KB, 下载次数: 0)

2016-7-9 23:16 上传

点击文件名下载附件