[已解决]几个月的数据，固定间隔1440行插入两行，求平均值

lvcy

几个月的数据，一天一分钟一个数据，每天1440个数，要求每天的平均值，可以在每天结束的一行插入两行，求这一天的平均值，然后把每天汇总一起。

最佳答案

月排行榜 / 总排行榜

vitrel

2023-4-4 14:35

嗯，已改。

1. Public Sub Test()
   
2.     Dim Sh As Worksheet, Sh2 As Worksheet, Arr()
   
3.     Dim Lr&, i&, j%, k%, r1&, r2& 'r1、r2分别代表同一天里的行首和行尾
   
4. 
   
5.     Set Sh = ThisWorkbook.Worksheets("Sheet1")
   
6.     Lr = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row '最后一行
   
7.     r1 = 1
   
8.     For i = 2 To Lr + 1
   
9.         If (DateDiff("D", Sh.Cells(i - 1, 1), Sh.Cells(i, 1)) <> 0) Or (i = Lr + 1) Then
   
10.             r2 = i - 1
    
11.             k = k + 1
    
12.             ReDim Preserve Arr(1 To 8, 1 To k)
    
13.             Arr(1, k) = DateValue(Sh.Cells(r1, 1)) '日期
    
14.             For j = 1 To 7 '各列平均数
    
15.                 Arr(j + 1, k) = Application.Average(Sh.Range(Sh.Cells(r1, j + 1), Sh.Cells(r2, j + 1))) '利用工作表函数取平均值是最快的
    
16.             Next j
    
17.             r1 = i
    
18.         End If
    
19.     Next i
    
20. 
    
21.     Set Sh2 = Sheets.Add '新建工作表
    
22.     Sh2.[A1].Resize(k, 8) = Application.Transpose(Arr) '将数组转置后输出到新工作表中
    
23. End Sub

复制代码

跳转到最佳答案楼层

vitrel

楼主，您好！
您的要求不难实现，
只是您最好能上附件，哪怕是胡乱造些假数据，
别人才能根据您提供的数据来写代码。

lvcy

vitrel 发表于 2023-4-3 09:20
楼主，您好！
您的要求不难实现，
只是您最好能上附件，哪怕是胡乱造些假数据，

您好，我上传了一些数据，我自己是录了一个宏，就是在每天结尾1440行插入两行，求上面的平均值，然后复制这些平均值到另一个sheet里，再把最前面的1442行删掉，结束宏。最后将sheetl里的平均值复制到另一个表格里。
您有更快的方法嘛，请赐教，谢谢！！！

vitrel

楼主，按您意思做了，您试试看吧。

1. Public Sub Test()
   
2.     Dim D As Object, Sh As Worksheet, Sh2 As Worksheet
   
3.     Dim Lr&, i&, r1&, r2& 'r1、r2分别代表同一天里的行首和行尾
   
4. 
   
5.     Set D = CreateObject("Scripting.Dictionary") '在本例中，利用数组记录数据，比用数组方便一些
   
6.     D("日期") = "平均值" '表头
   
7. 
   
8.     Set Sh = ThisWorkbook.Sheets(1)
   
9.     Lr = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row '最后一行
   
10. 
    
11.     r1 = 1
    
12.     For i = 2 To Lr
    
13.         If DateDiff("D", Sh.Cells(i - 1, 1), Sh.Cells(i, 1)) <> 0 Then
    
14.             r2 = i - 1
    
15.             D(DateValue(Sh.Cells(r1, 1))) = Application.Average(Sh.Range(Sh.Cells(r1, "C"), Sh.Cells(r2, "H"))) '利用工作表函数取平均值是最快的
    
16.             r1 = i
    
17.         End If
    
18.     Next i
    
19. 
    
20.     '待上面的循环结束后，还要取一下最后一个日期的平均值
    
21.     D(DateValue(Sh.Cells(r1, 1))) = Application.Average(Sh.Range(Sh.Cells(r1, "C"), Sh.Cells(Lr, "H")))
    
22. 
    
23.     Set Sh2 = Sheets.Add '新建工作表
    
24.     Sh2.[A1].Resize(D.Count, 2) = Application.Transpose(Array(D.Keys, D.Items)) '将字典输出到新工作表中
    
25. End Sub

复制代码

lvcy

vitrel 发表于 2023-4-4 10:32
楼主，按您意思做了，您试试看吧。

您好，您给我的程序我试用了，确实可以，但是我可能没表达清楚，我给的是每天有7列数据，最后求的是7列数据一天的平均值，一天下来有7个数，不是这一天所有数据的平均值。

vitrel

嗯，已改。

1. Public Sub Test()
   
2.     Dim Sh As Worksheet, Sh2 As Worksheet, Arr()
   
3.     Dim Lr&, i&, j%, k%, r1&, r2& 'r1、r2分别代表同一天里的行首和行尾
   
4. 
   
5.     Set Sh = ThisWorkbook.Worksheets("Sheet1")
   
6.     Lr = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row '最后一行
   
7.     r1 = 1
   
8.     For i = 2 To Lr + 1
   
9.         If (DateDiff("D", Sh.Cells(i - 1, 1), Sh.Cells(i, 1)) <> 0) Or (i = Lr + 1) Then
   
10.             r2 = i - 1
    
11.             k = k + 1
    
12.             ReDim Preserve Arr(1 To 8, 1 To k)
    
13.             Arr(1, k) = DateValue(Sh.Cells(r1, 1)) '日期
    
14.             For j = 1 To 7 '各列平均数
    
15.                 Arr(j + 1, k) = Application.Average(Sh.Range(Sh.Cells(r1, j + 1), Sh.Cells(r2, j + 1))) '利用工作表函数取平均值是最快的
    
16.             Next j
    
17.             r1 = i
    
18.         End If
    
19.     Next i
    
20. 
    
21.     Set Sh2 = Sheets.Add '新建工作表
    
22.     Sh2.[A1].Resize(k, 8) = Application.Transpose(Arr) '将数组转置后输出到新工作表中
    
23. End Sub

复制代码

lvcy

vitrel 发表于 2023-4-4 14:35
嗯，已改。

       谢谢大神，完美解决我的问题，真的感谢！！！我的工作经常要处理这些机组DCS数据，有时候是一整天的数据，还有的一天内多个时间段的。你写的这段程序真的很棒，我可在你的基础上魔改魔改，不懂的再请教你。谢谢！！！