琢磨很长时间未果，只能请教大神，对计算效率有要求

天悦行空

核心思路是按列统计数值为0的单元格，上一位的数值和下一次出现0的距离，然后将出现的次数累加计算。具体详见附件中说明，每步计算过程都结合案例说明，邀请各路大神帮助解答，速度越快越好。
有疑问随时留言，谢谢(*^▽^*)

microyip

莫名其妙的计算

蓝桥玄霜

请见代码。
以表1为例。

天悦行空

蓝桥玄霜 发表于 2018-9-13 09:40
请见代码。
以表1为例。

老师，区域不固定，也就是说不知道右下角单元格位置

lsdongjh

1. 
   
2. Sub Test()
   
3.     Dim shSource As Worksheet, shResult As Worksheet
   
4.     Dim arrSource As Variant, lngFind As Long
   
5.     Dim arrMiddle As Variant, arrResult As Variant
   
6.     Dim lngRow As Long, lngCol As Long, lngIndex As Long
   
7.     Dim lngRowID As Long, lngColID As Long
   
8.     Dim lngMax As Long, lngMaxRows As Long
   
9.    
   
10.     Set shSource = Sheets("Sheet1")
    
11.     Set shResult = Sheets("Sheet1")
    
12.    
    
13.     arrSource = shSource.Range("C13:AI206")
    
14.     lngMax = Application.WorksheetFunction.Max(arrSource) '区域中最大的数，以便确认上一位可能出现的最大值
    
15.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
16.     '记录符合条件的情况
    
17.     lngCol = UBound(arrSource, 2) * 3
    
18.     lngMaxRows = UBound(arrSource)
    
19.     ReDim arrMiddle(1 To lngMaxRows, 1 To lngCol) '中间过程
    
20.     lngFind = 0
    
21.     For lngCol = 1 To UBound(arrSource, 2)
    
22.         lngIndex = 1
    
23.         For lngRow = 1 To UBound(arrSource)
    
24.             If arrSource(lngRow, lngCol) = lngFind Then
    
25.                 arrMiddle(lngIndex, (lngCol - 1) * 3 + 1) = lngRow
    
26.                 If lngRow > 1 Then arrMiddle(lngIndex, (lngCol - 1) * 3 + 2) = arrSource(lngRow - 1, lngCol)
    
27.                 lngIndex = lngIndex + 1
    
28.             End If
    
29.         Next
    
30.     Next
    
31.    
    
32.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
33.     '计算下一位距离
    
34.     lngMaxRows = 0
    
35.     For lngCol = 3 To UBound(arrMiddle, 2) Step 3
    
36.         For lngRow = 1 To UBound(arrMiddle)
    
37.             If arrMiddle(lngRow + 1, lngCol - 2) = "" Then Exit For
    
38.             arrMiddle(lngRow, lngCol) = arrMiddle(lngRow + 1, lngCol - 2) - arrMiddle(lngRow, lngCol - 2)
    
39.             If lngMaxRows < arrMiddle(lngRow, lngCol) Then lngMaxRows = arrMiddle(lngRow, lngCol)
    
40.         Next
    
41.     Next
    
42.    
    
43.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
44.     '初始化结果集
    
45.     ReDim arrResult(0 To lngMax + 1, 0 To lngMaxRows) As Long '最终结果架构
    
46.     For lngCol = 1 To lngMaxRows
    
47.         arrResult(0, lngCol) = lngCol
    
48.     Next
    
49.      For lngRow = 1 To lngMax + 1
    
50.         arrResult(lngRow, 0) = lngRow - 1
    
51.      Next
    
52. 
    
53.    
    
54.     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
55.     '规整结果数据
    
56.     For lngCol = 1 To UBound(arrMiddle, 2) - 1 Step 3
    
57.         For lngRow = 1 To UBound(arrMiddle)
    
58.             If arrMiddle(lngRow, lngCol + 1) <> "" And arrMiddle(lngRow, lngCol + 2) <> "" Then
    
59.                 lngRowID = arrMiddle(lngRow, lngCol + 1) + 1
    
60.                 lngColID = arrMiddle(lngRow, lngCol + 2)
    
61.                 arrResult(lngRowID, lngColID) = arrResult(lngRowID, lngColID) + 1
    
62.             End If
    
63.         Next
    
64.     Next
    
65.    
    
66.     shResult.Range("C208:AI" & Rows.Count).ClearContents
    
67.     shResult.Range("C208").Resize(UBound(arrResult) + 1, UBound(arrResult, 2) + 1) = arrResult
    
68. End Sub
    

复制代码

天悦行空

这么长啊，我试下看看

天悦行空

蓝桥玄霜 发表于 2018-9-13 09:40
请见代码。
以表1为例。

老师，我算出结果不对啊

天悦行空

lsdongjh 发表于 2018-9-13 14:54

数据量多的时候会提示越界

蓝桥玄霜

天悦行空 发表于 2018-9-13 13:10
老师，区域不固定，也就是说不知道右下角单元格位置

单元格区域的位置可以修改，有多种语句看用：
Arr = [b2].CurrentRegion
Arr=Sheet1.usedRange
Arr=[b2:x500]

天悦行空

有哪位老师有更快速的计算么？