[已解决]请高手帮忙写段VBA 像H列这样

hanjia

数据太多 用函数电脑卡的都动不了  
如付件  查找 1,2,3,4 有其中3个以上的显示 0


工作表.zip (9.68 KB, 下载次数: 8)

2016-7-7 05:52 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2016-7-7 09:52

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, 3, 6, 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
End Sub

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
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. For i = 2 To UBound(arr)
   
6.     s = 0
   
7.     For j = 1 To UBound(arr, 2)
   
8.         For k = 1 To 4
   
9.             If arr(i, j) = k Then s = s + 1
   
10.         Next
    
11.         If s >= 3 Then brr(i, 1) = 0: Exit For
    
12.     Next
    
13.     If s < 3 Then brr(i, 1) = brr(i - 1, 1) + 1
    
14. Next
    
15. Range("h1").Resize(UBound(brr)) = brr
    
16. End Sub

复制代码

hanjia

dsmch 发表于 2016-7-7 08:58

谢谢老师帮忙
请问  For k = 1 To 4 这句是查找 1,2,3,4 是连上的
如果4个数不是连上的应该怎么改？
比如 1,3,6,8

dsmch

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, 3, 6, 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
End Sub