通过成绩表和参数表、教师任课表。得到对教师的量化结果。求解决

gooodok

通过前面的“成绩”和“参数”表，得到量化结果表。

以前一直是录制的宏。但学校数和班数一变。就 不能用了。计算速度也太慢

想请大师给个宏。解决这个问题，谢谢.

gooodok

里面的量化结果不是标准的，是随便复制过来的。

lzqlaj

修改一下参数表。

lzqlaj

Sub slyf()
    Dim r1%, r2%, r3%, i1%, i2%, i3%, i4%, arr, brr, crr, drr, yxrs, jgrs, dfrs, bjrs, bjzf
    Dim xx As Object, km As Object, js As Object, bj As Object
    Set xx = CreateObject("scripting.dictionary")
    Set km = CreateObject("scripting.dictionary")
    Set bj = CreateObject("scripting.dictionary")
    Set js = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    On Error Resume Next
    r1 = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Row
    brr = Sheet2.Range("a8:f" & r1)
    For j = 3 To 6
        For i = 2 To UBound(brr)
            xx(brr(i, j) & brr(i, 1)) = brr(i, 1)
            km(brr(i, j) & brr(i, 1)) = brr(1, j)
            If bj(brr(i, j) & brr(i, 1)) <> "" Then
                bj(brr(i, j) & brr(i, 1)) = bj(brr(i, j) & brr(i, 1)) & "," & brr(i, 2)
            Else
                bj(brr(i, j) & brr(i, 1)) = brr(i, 2)
            End If
            js(brr(i, j) & brr(i, 1)) = brr(i, j)
        Next i
    Next j
    Sheet4.Range("a2").Resize(km.Count, 1).Value = WorksheetFunction.Transpose(Array(km.items))
    Sheet4.Range("b2").Resize(xx.Count, 1).Value = WorksheetFunction.Transpose(Array(xx.items))
    Sheet4.Range("c2").Resize(js.Count, 1).Value = WorksheetFunction.Transpose(Array(js.items))
    Sheet4.Range("d2").Resize(js.Count, 1).Value = WorksheetFunction.Transpose(Array(bj.items))
    r2 = Sheet4.Cells(Sheet4.Rows.Count, 1).End(xlUp).Row
    arr = Sheet4.Range("a1").Resize(r2, 13)
    r3 = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
    crr = Sheet1.Range("a1").Resize(r3, 8)
    For i2 = 2 To r2
        yxrs = 0
        jgrs = 0
        dfrs = 0
        bjrs = 0
        bjzf = 0
        For i1 = 3 To 6
            If arr(i2, 1) = Sheet2.Cells(1, i1) Then
                yx = Sheet2.Cells(3, i1)
                jg = Sheet2.Cells(4, i1)
                df = Sheet2.Cells(5, i1)
            End If
        Next i1
        drr = Split(arr(i2, 4), ",")
        For i3 = 5 To 8
            If InStr(arr(i2, 1), crr(1, i3)) > 0 Then
                For i4 = 2 To r3
                    If InStr(arr(i2, 2), crr(i4, 1)) > 0 Then
                        For i5 = 0 To UBound(drr)
                            If InStr(drr(i5), crr(i4, 3)) > 0 Then
                                bjrs = bjrs + 1
                                bjzf = crr(i4, i3) + bjzf
                                If crr(i4, i3) >= yx Then yxrs = yxrs + 1
                                If crr(i4, i3) >= jg Then jgrs = jgrs + 1
                                If crr(i4, i3) <= df Then dfrs = dfrs + 1
                            End If
                        Next i5
                    End If
                Next i4
                arr(i2, 6) = bjrs
                arr(i2, 7) = yxrs
                If bjrs > 0 Then arr(i2, 8) = yxrs / bjrs
                arr(i2, 9) = jgrs
                If bjrs > 0 Then arr(i2, 10) = jgrs / bjrs
                arr(i2, 11) = dfrs
                If bjrs > 0 Then arr(i2, 12) = dfrs / bjrs
                If bjrs > 0 Then arr(i2, 13) = bjzf / bjrs
                Exit For
            End If
        Next i3
    Next i2
    Sheet4.Range("a1").Resize(UBound(arr), 13) = arr
    Application.ScreenUpdating = True
End Sub

lzqlaj

k11在两个学校教3个班级科学，按学校算两次。

lzqlaj

见附件。。。

lzqlaj

InStr函数应该换成StrComp函数。