数据间隔7天进行汇总

lgzxmlg

一把小刀闯天下 发表于 2019-2-17 11:35
Option Explicit

Sub test()

对数据按周进行汇总 (2).zip (13.11 KB, 下载次数: 10)

2019-2-17 12:09 上传

点击文件名下载附件

老师：我对第五周数据验证了下，结果出现错误，请老师核实下代码。

micch

1. =SUMIF(数据!$A:$A,"<="&$B3,数据!B:B)-SUM(C$1:C2)

复制代码

C3，右拉下拉，B列日期改过来。

一把小刀闯天下

lgzxmlg 发表于 2019-2-17 12:10
老师：我对第五周数据验证了下，结果出现错误，请老师核实下代码。

'我还以为就B列汇总，已修改，，，

Option Explicit

Sub test()
  Dim arr, i, j, m, sum, n
  arr = Sheets("数据").[a1].CurrentRegion.Offset(2)
  ReDim brr(1 To UBound(arr, 1), UBound(arr, 2)), sum(2 To UBound(arr, 2))
  For i = 1 To UBound(arr, 1) - 2
    For j = 2 To UBound(arr, 2): sum(j) = sum(j) + arr(i, j): Next
    If i Mod 7 = 0 Or i = UBound(arr, 1) - 2 Then
      m = m + 1: n = n + 1
      brr(m, 0) = Format(n, "第0周"): brr(m, 1) = arr(i, 1)
      For j = 2 To UBound(sum): brr(m, j) = sum(j): Next
      ReDim sum(2 To UBound(arr, 2))
    End If
  Next
  With Sheets("结果").[a3]
    .Resize(Rows.Count - 2, UBound(brr, 2) + 1).ClearContents
    .Resize(m, UBound(brr, 2) + 1) = brr
  End With
End Sub

lgzxmlg

一把小刀闯天下 发表于 2019-2-17 12:37
'我还以为就B列汇总，已修改，，，

Option Explicit

解决，老师辛苦了。

micch

换代码试试

1. Sub test()
   
2.     arr = Sheets("数据").[a1].CurrentRegion.Offset(2)
   
3.     ReDim brr(1 To UBound(arr), UBound(arr, 2))
   
4.         For i = 1 To UBound(arr) - 2
   
5.             n = Int((i - 1) / 7) + 1
   
6.             brr(n, 0) = Format(n, "第0周"):     brr(n, 1) = arr(i, 1)
   
7.             For k = 2 To UBound(arr, 2):        brr(n, k) = brr(n, k) + arr(i, k)
   
8.         Next k, i
   
9.     Sheets("结果").[a3].Resize(n, UBound(brr, 2) + 1) = brr
   
10. End Sub

复制代码