分组求第一个和最后一个之间的天数

kort20034

由上往下每100个合格为一组，想得出组里面第一个和最后一个之间的天数，如下图描述，谢谢！

grf1973

跟模拟结果略有不同。

cidanji

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.11.14
   
2.     Application.ScreenUpdating = False
   
3.     r = Cells(Rows.Count, 2).End(3).Row
   
4.     arr = [b1].Resize(r, 2)
   
5.     ReDim zrr(1 To r, 1 To 2)
   
6.     For i = 2 To UBound(arr)
   
7.         If arr(i, 2) = "合格" Then
   
8.             m = m + 1
   
9.             zrr(m, 1) = DateValue(CDate(arr(i, 1)))
   
10.             zrr(m, 2) = arr(i, 2)
    
11.         End If
    
12.     Next
    
13.     ReDim brr(1 To 2, 1 To 100)
    
14.     k = 100
    
15.     For i = 1 To UBound(zrr) Step k
    
16.         n = n + 1
    
17.         brr(1, n) = n
    
18.         If i + k - 1 < m Then
    
19.             rq1 = zrr(i, 1)
    
20.             rq2 = zrr(i + k - 1, 1)
    
21.             brr(2, n) = DateDiff("d", rq2, rq1)
    
22.         Else
    
23.             brr(2, n) = Format((m - i + 1) / 100, "0.00%")
    
24.         End If
    
25.     Next
    
26.     [l6].Resize(2, n) = brr
    
27.     [l6].Resize(2, n).Borders.LineStyle = 1
    
28.     Application.DisplayAlerts = True
    
29. End Sub
    

复制代码

Qs18

1. Sub qs()
   
2.     Dim arr, i
   
3.     arr = Sheet3.Range("a1").CurrentRegion.Value
   
4.     ReDim brr(1 To UBound(arr), 1 To 1)
   
5.     ReDim crr(1 To 2, 1 To 100)
   
6.     For i = 2 To UBound(arr)
   
7.         If arr(i, 3) = "合格" Then
   
8.             m = m + 1
   
9.             brr(m, 1) = CDate(Format(CDate(arr(i, 2)), "yyyy/m/d"))
   
10.         End If
    
11.     Next
    
12.     For i = 1 To m Step 100
    
13.     n = n + 1: y = y + 100
    
14.     x = n
    
15.     b = 0
    
16.     If y < m Then
    
17.         b = brr(i, 1) - brr(y, 1)
    
18.     Else
    
19.         b = Format((m Mod 100) / 100, "0%")
    
20.     End If
    
21.     c = c + 1
    
22.     crr(1, c) = x: crr(2, c) = b
    
23.     Next
    
24.     Sheet3.Range("l4").Resize(2, c) = crr
    
25. End Sub

复制代码

Qs18

试试..........

grf1973

受楼上启发，发现问题所在。应该是整数相差，而不是相减后取整。另外，剩余是行数/100，而不是天数相减/100。

Qs18

试试...........

听歌的海

参与一下

1. Sub 计算天数()
   
2.     arr = Sheets("sheet3").[b1].CurrentRegion
   
3.     ReDim brr(1 To UBound(arr), 1 To 2)
   
4.     ReDim crr(1 To UBound(arr), 1 To 2)
   
5.    
   
6.     With Sheet3
   
7.     For j = 1 To UBound(arr)
   
8.         If arr(j, 2) = "合格" Then
   
9.             t = t + 1
   
10.             y = t Mod 100
    
11.             If y = 0 Then
    
12.                 s = s + 1
    
13.                 brr(s, 1) = s
    
14.                 brr(s, 2) = arr(j, 1)
    
15.             ElseIf y = 1 Then
    
16.                 i = i + 1
    
17.                 crr(i, 2) = arr(j, 1)
    
18.             End If
    
19.         End If
    
20.     Next j
    
21.     If i > s Then
    
22.         brr(s + 1, 1) = i
    
23.     End If
    
24.     For j = 1 To i
    
25.         Cells(10, 11 + j) = brr(j, 1)
    
26.         If j < i Then
    
27.             Cells(11, 11 + j) = DateDiff("d", brr(j, 2), crr(j, 2))
    
28.         Else
    
29.             Cells(11, 11 + j) = Format((t - s * 100) / 100, "0.00%")
    
30.         End If
    
31.     Next j
    
32.     End With
    
33. End Sub

复制代码