日期间隔天数统计数据

不知道为什么

lgzxmlg 发表于 2019-3-6 18:11
老师：能否告下代码，亟待知道如何处理。

下午不在电脑边，晚上抽空发。不好意思

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim rq1 As Date
   
5.   Dim rq2 As Date
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     rq1 = Int(Application.Min(.Range("a2:a" & r)))
   
9.     rq2 = Int(Application.Max(.Range("a2:a" & r)))
   
10.     ts = Application.Ceiling(rq2 - rq1 + 1, 5)
    
11.     ReDim brr(1 To ts / 5, 1 To 5)
    
12.     For i = 1 To UBound(brr)
    
13.       brr(i, 1) = rq1 + (i - 1) * 5
    
14.       brr(i, 2) = brr(i, 1) + 4
    
15.     Next
    
16.     arr = .Range("a2:g" & r)
    
17.     For i = 1 To UBound(arr)
    
18.       For j = 1 To UBound(brr)
    
19.         If arr(i, 1) >= brr(j, 1) And arr(i, 1) <= brr(j, 2) Then
    
20.           brr(j, 3) = brr(j, 3) + arr(i, 3)
    
21.           brr(j, 4) = brr(j, 4) + arr(i, 7)
    
22.           brr(j, 5) = brr(j, 5) + 1
    
23.         End If
    
24.       Next
    
25.     Next
    
26.   End With
    
27.   For i = 1 To UBound(brr)
    
28.     If Len(brr(i, 5)) <> 0 And brr(i, 5) <> 0 Then
    
29.       brr(i, 3) = Round(brr(i, 3) / brr(i, 5), 2)
    
30.       brr(i, 4) = Round(brr(i, 4) / brr(i, 5), 2)
    
31.     End If
    
32.   Next
    
33.   With Worksheets("sheet2")
    
34.     .UsedRange.Offset(1, 0).ClearContents
    
35.     .Range("a2").Resize(UBound(brr), UBound(brr, 2) - 1) = brr
    
36.   End With
    
37. End Sub
    

复制代码

chxw68

详见附件。

lgzxmlg

不知道为什么 发表于 2019-3-6 18:28
下午不在电脑边，晚上抽空发。不好意思

谢谢老师加息

lgzxmlg

chxw68 发表于 2019-3-6 18:35
详见附件。

老师：我核算了下，偏差还是较大，不知什么原因。

lgzxmlg

chxw68 发表于 2019-3-6 18:35
详见附件。

副本按最早出现的日期每间隔5天求平均数.zip (32.5 KB, 下载次数: 3)

2019-3-6 23:26 上传

点击文件名下载附件

老师：我核算了下，偏差还是较大，不知什么原因。

lgzxmlg

chxw68 发表于 2019-3-6 18:35
详见附件。

老师不好意思，晚上没有细看就提了问题，我加了arr(i,3)>0和arr(i,7)>0问题解决。谢谢老师。

chxw68

lgzxmlg 发表于 2019-3-7 07:38
老师不好意思，晚上没有细看就提了问题，我加了arr(i,3)>0和arr(i,7)>0问题解决。谢谢老师。

这个可能还存在点问题：比如C和Cr不是同时有数据或同时没数据，这个平均值计算结果就不准确了。

lgzxmlg

chxw68 发表于 2019-3-7 08:39
这个可能还存在点问题：比如C和Cr不是同时有数据或同时没数据，这个平均值计算结果就不准确了。

我想分开判断，但后面代码不会。我参考他人的学者改吧。我改成这样，还是有偏差，不知错在哪。
Sub test()
  Dim r%, i%
  Dim arr, brr
  Dim rq1 As Date
  Dim rq2 As Date
  With Worksheets("sheet1")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    rq1 = Int(Application.Min(.Range("a2:a" & r)))
    rq2 = Int(Application.Max(.Range("a2:a" & r)))
    ts = Application.Ceiling(rq2 - rq1 + 1, 5)
    ReDim brr(1 To ts / 5, 1 To 5)
    For i = 1 To UBound(brr)
      brr(i, 1) = rq1 + (i - 1) * 5
      brr(i, 2) = brr(i, 1) + 4
    Next
    arr = .Range("a2:g" & r)
    For i = 1 To UBound(arr)
      For j = 1 To UBound(brr)
        If arr(i, 1) >= brr(j, 1) And arr(i, 1) <= brr(j, 2) And arr(i, 3) > 0 Then
          brr(j, 3) = brr(j, 3) + arr(i, 3)
          brr(j, 4) = brr(j, 4) + arr(i, 7)
          brr(j, 5) = brr(j, 5) + 1
          If arr(i, 1) >= brr(j, 1) And arr(i, 1) <= brr(j, 2) And arr(i, 7) > 0 Then
          brr(j, 3) = brr(j, 3) + arr(i, 3)
          brr(j, 4) = brr(j, 4) + arr(i, 7)
          brr(j, 5) = brr(j, 5) + 1
        End If
        End If
      Next
    Next
  End With
  For i = 1 To UBound(brr)
    If Len(brr(i, 5)) <> 0 And brr(i, 5) <> 0 Then
      brr(i, 3) = Round(brr(i, 3) / brr(i, 5), 2)
      brr(i, 4) = Round(brr(i, 4) / brr(i, 5), 2)
    End If
  Next
  With Worksheets("sheet2")
    .UsedRange.Offset(1, 0).ClearContents
    .Range("a2").Resize(UBound(brr), UBound(brr, 2) - 1) = brr
  End With
End Sub

lgzxmlg

chxw68 发表于 2019-3-6 18:35
详见附件。

副本按最早出现的日期每间隔5天求平均数.rar (29.78 KB, 下载次数: 2)

2019-3-18 07:08 上传

点击文件名下载附件

老师：我把统计间隔天数改为可变化的。为什么1天统计时不出结果？