|
|
Option Explicit
Dim arr() '数据源
Dim arrResult() '结果
Dim NotRecord As Integer '非记录（指平均行或空白行）
Dim Record As Integer '记录
Const LineCount = 20 '行数 = 多行记录 + 1行平均值
'主程序
Sub test()
Dim i As Integer, j As Integer
Sheets("原始数据表").Select
' arr = Range("a1").CurrentRegion.Value
arr = Range("a1:ab" & Range("b65536").End(3).Row).Value
ReDim arrResult(1 To UBound(arr) * LineCount, 1 To UBound(arr, 2))
NotRecord = 0
Record = 0
For i = 2 To UBound(arr)
'如果本行和上行不同，则处理平均行
If i > 2 And arr(i, 4) <> arr(i - 1, 4) Then Call AverageLine(i)
'某个产品进行添加记录
Record = Record + 1
If Record < LineCount Then
For j = 1 To UBound(arr, 2)
'结果的行号 = 累计的记录数 + 累计的非记录行数
arrResult(i + NotRecord, j) = arr(i, j)
Next j
End If
Next i
'最后一个产品的平均行，单独处理
Call AverageLine(i)
Sheets(2).Activate
Cells.Clear
Range("F:R").NumberFormat = "0.0"
Range("Z:AB").NumberFormat = "0.00"
Range("a1").Resize(i + NotRecord, UBound(arrResult, 2)) = arrResult '结果
Range("a1").Resize(1, UBound(arr, 2)) = Application.Index(arr, 1, 0) '标题
Range("a1").Select
Call FillColor(LineCount, UBound(arr, 2)) '可选
End Sub
'处理平均行
Sub AverageLine(iData)
Dim dic As Object '字典，用于文本型产品的计数
Dim ProductAvg As Long '产品的平均行行号
Dim ProductSum As Double '数字型产品的和
Dim ProductCount As Integer '产品的累计次数
Dim ProductColumn As Integer '产品的参照列号
Dim i As Integer, j As Integer, startRow As Integer, endRow As Integer
Set dic = CreateObject("scripting.dictionary")
NotRecord = NotRecord + (LineCount - Record) 'LineCount - Record表示非记录数，即平均行和空白行
ProductAvg = iData + NotRecord - 1 '某产品的平均行行号 = 累计记录数 + 累计非记录数 - 1
startRow = ProductAvg - LineCount + 1
endRow = ProductAvg - 1
'从第6列（株高cm），到最后1列（经济系数），求各产品的平均值
For j = 6 To UBound(arr, 2)
'1）清零
ProductSum = 0: ProductCount = 0: ProductColumn = 0: dic.RemoveAll
'2）求和
For i = startRow To endRow
'如果产品的值非空
If arrResult(i, j) <> "" Then
'如果产品的值是数字
If IsNumeric(arrResult(i, j)) Then
'累计产品值的和
ProductSum = ProductSum + arrResult(i, j)
End If
'更新终止排号
arrResult(ProductAvg, 2) = arrResult(i, 2)
End If
Next i
'3）求次数
'更新产品的参照列号
Select Case j
Case 10, 14
ProductColumn = 16
Case Else
ProductColumn = j
End Select
'求和的列与求次数的列，因为可能不一样，所以必须再循环
For i = startRow To endRow
'如果产品的值非空
If arrResult(i, ProductColumn) <> "" Then
'如果产品的值是数字
If IsNumeric(arrResult(i, ProductColumn)) Then
'数字型产品的累计次数
ProductCount = ProductCount + 1
Else
'文本型产品的累计次数
dic(arrResult(i, ProductColumn)) = dic(arrResult(i, ProductColumn)) + 1
End If
End If
Next i
'4）求平均值
If ProductCount Then arrResult(ProductAvg, j) = ProductSum / ProductCount '数字型 = 和 / 次数
If dic.count Then arrResult(ProductAvg, j) = getItem(dic.keys, dic.items) '文本型 = 最多次数的条目
Next j
'处理前5列
arrResult(ProductAvg, 1) = "" 'A列，统计号
arrResult(ProductAvg, 2) = " " & arrResult(startRow, 2) & "-" & arrResult(ProductAvg, 2) 'B列，排号
arrResult(ProductAvg, 3) = "平均" 'C列，材料序号2014年
arrResult(ProductAvg, 4) = arrResult(startRow, 4) 'D列，材料名称
arrResult(ProductAvg, 5) = "平均" 'E列，株号
Record = 0
End Sub
'自定义函数：最多次数的条目
Function getItem(k, t) As String
Dim i As Integer
Dim temp As Integer '最大次数
Dim Id As Integer '最大次数的下标
For i = 0 To UBound(k)
'k是条目的数组，t是条目次数的数组
If temp < t(i) Then
temp = t(i) '最大次数
Id = i '最大次数的下标
End If
Next i
getItem = k(Id) '最大次数下标对应的条目
End Function
'将结果表里每种材料名称的平均行填充颜色
Sub FillColor(LineCount, c)
Dim r, i
Sheets(2).Activate
r = Range("b65536").End(xlUp).Row
For i = r To 2 Step -LineCount
Range(Cells(i, 1), Cells(i, c)).Interior.ColorIndex = 15
Next i
End Sub
插入空行并求平均值（20160501 求平均问题）10.rar
(97.58 KB, 下载次数: 8)
|
|
楼主: shzzhy
IP卡
狗仔卡
发表于 2016-12-12 18:42
显身卡
楼主
！！！
