求助一个复杂的平均分计算

翁知江安

不好意思，没注意到学校是四中的，程序算全县可以，算四中的不对，要改

翁知江安

Sub test()
Dim ar, cr, dr As Variant
Dim i, j, k, m, n, mc, mm, icolumn1, icolumn2 As Integer, isum
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].CurrentRegion
ar = Sheet1.[a1].Resize(UBound(ar), UBound(ar, 2) + 1)
ar(1, UBound(ar, 2)) = "32班": ar(1, UBound(ar, 2) - 1) = "全县"
d(ar(1, UBound(ar, 2))) = UBound(ar, 2): d(ar(1, UBound(ar, 2) - 1)) = UBound(ar, 2) - 1
For j = 5 To UBound(ar, 2) - 2
      ar(1, j) = Sheet1.Cells(1, j + 13)
      d(ar(1, j)) = j
Next
For i = 2 To UBound(ar)
  If ar(i, 4) = "沂水四中" Then
       mm = mm + 1
       If mm = 1 Then
           n = n + 1: mc = ar(i, UBound(ar, 2) - 1)
           ar(i, UBound(ar, 2)) = n
        Else
           If mc < ar(i, UBound(ar, 2) - 1) Then
           n = n + 1
           ar(i, UBound(ar, 2)) = mm: mc = ar(i, UBound(ar, 2) - 1)
             Else
               If mc = ar(i, UBound(ar, 2) - 1) Then
                 ar(i, UBound(ar, 2)) = n
                 End If
            End If
         End If
    Else
        ar(i, UBound(ar, 2)) = 0
    End If
Next
cr = Sheet1.Range("p1:x" & Sheet1.[p65536].End(xlUp).Row)
ReDim dr(1 To UBound(cr) - 1, 1 To UBound(cr, 2) - 2)
For i = 2 To UBound(cr)
    icolumn1 = d(cr(i, 1))
    For j = 3 To UBound(cr, 2)
       icolumn2 = d(cr(1, j))
        For k = 2 To UBound(ar)
            If ar(k, icolumn1) <= cr(i, 2) Then
               If ar(k, icolumn1) > 0 Then
               If ar(k, icolumn2) > 0 Then
                m = m + 1
               isum = ar(k, icolumn2) + isum
                End If
                End If
             Else
              Exit For
            End If
        Next
         If m > 0 Then
           dr(i - 1, j - 2) = Format(isum / m, "0.000")
         Else
           dr(i - 1, j - 2) = "平均数不存在"
          End If
          m = 0: isum = 0
      Next
Next
Sheet1.[r2].Resize(100, 20).ClearContents
Sheet1.[r2].Resize(UBound(dr), UBound(dr, 2)) = dr
Set ar = Nothing
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正。

blackttea1

感谢楼主分享