在指定区间，查找数字1的个数

hongandk

老师：
    我请教的问题是：在指定区间，查找数字1的个数。
    数据区有20列数据，想要实现的效果：
    1.在F25中输入数字"5"，表示以5列数据为基准，查找1的个数，同时将结果输入到表2中。
    2.在F25中输入数字"10"，表示以10列数据为基准，查找1的个数，同时将结果输入到表2中。

    注：F25中的数值能被数据区列数整除。比如：本例中F25中的数值只能填入1、2、4、5、10、20这6个数字。
    分区数字.rar (348.94 KB, 下载次数: 1)

2019-10-4 11:08 上传

点击文件名下载附件

   

hongandk

yaozong 发表于 2019-10-4 12:43

yaozong老师：
        您提供的VBA只对20列数据有效，数据超过20列时失效，现上传图片及附件，请老师指正。
         分区数字.rar (399.85 KB, 下载次数: 1)

2019-10-4 22:47 上传

点击文件名下载附件

        

719404338

=COUNTIF(A1:z100,1)

yaozong

1. Sub test()
   
2. Dim arr, i&, j&, k&, m&, n&, nn&, js&, x&, y&, s&
   
3. arr = Sheets("表1").[e2].CurrentRegion.Value
   
4. x = UBound(arr, 2): y = UBound(arr)
   
5. s = Sheets("表1").[F25].Value
   
6. nn = Application.Ceiling(y / s, 1)
   
7. ReDim brr(1 To y - 1, 1 To nn)
   
8. For j = 1 To x Step s
   
9.   n = Application.Ceiling(j / s, 1)
   
10.   For i = 2 To y
    
11.     For k = j To j + s - 1
    
12.       If arr(i, k) = 1 Then
    
13.         js = js + 1
    
14.       End If
    
15.     Next
    
16.      brr(i - 1, n) = js: js = 0
    
17.   Next
    
18. Next
    
19. Sheets("表2").[e2].CurrentRegion.Offset(1).ClearContents
    
20. Sheets("表2").[e3].Resize(y - 1, n) = brr
    
21. End Sub

复制代码

yaozong

1. Sub test2() ''[f25]可填写任何数
   
2. Dim arr, i&, j&, k&, m&, n&, nn&, js&, x&, y&, s&, ss&
   
3. arr = Sheets("表1").[e2].CurrentRegion.Value
   
4. x = UBound(arr, 2): y = UBound(arr)
   
5. s = Sheets("表1").[F25].Value
   
6. If s > x Then Exit Sub
   
7. nn = Application.Ceiling(y / s, 1)
   
8. ReDim brr(1 To y - 1, 1 To nn)
   
9. For j = 1 To x Step s
   
10.   n = Application.Ceiling(j / s, 1)
    
11.   For i = 2 To y
    
12.     ss = IIf(x - j + 1 < s, x - j + 1, s)
    
13.     For k = j To j + ss - 1
    
14.       If arr(i, k) = 1 Then
    
15.         js = js + 1
    
16.       End If
    
17.     Next
    
18.      brr(i - 1, n) = js: js = 0
    
19.   Next
    
20. Next
    
21. Sheets("表2").Activate
    
22. [e2].CurrentRegion.Offset(1).ClearContents
    
23. [e3].Resize(y - 1, n) = brr
    
24. End Sub
    

复制代码

hongandk

yaozong 发表于 2019-10-4 12:43

yaozong老师：        大作已收悉，正解！非常感谢国庆假期给予解答，辛苦了。