汇总各工作表教师命题费用

sunshuangzhong

要求：       
1、从其它所有工作表中汇总出每人的命题次数（如果命题人有二人，次数分别为0.5)及审阅次数,结果写入本工作表的H和I列中       
2、根据其它表中该姓名命题学科及本工作表中的《命题标准》《审阅标准》表写入命题标准（F列)和审阅标准（G列)       
3、计算本表中的合计（J列），公式如下：命题标准*命题次数+审阅标准*审阅次数       
4、合计的最后一行添加：总金额，公式为合计之和，即J列和。       
5、如果各工作表中有姓名在本表中未出现，写在W列。       
       
       
       
备注：       
其它工作表中物理选修、物理必修、化学选修、化学必修、生物选修、生物必修、历史选修、历史必修、地理选修、地理必修、政治选修、政治必修       
的命题标准、审阅标准同物理、化学、生物、历史、地理、政治       


谢谢各位！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim ws As Worksheet
   
5.     Dim d As Object
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set d1 = CreateObject("scripting.dictionary")
   
8.     With Worksheets("汇总")
   
9.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.         .Range("h3:i" & r).ClearContents
    
11.         brr = .Range("a3:j" & r)
    
12.         For i = 1 To UBound(brr)
    
13.             d(brr(i, 2)) = i
    
14.         Next
    
15.     End With
    
16.     For Each ws In Worksheets
    
17.         If ws.Name <> "汇总" Then
    
18.             With ws
    
19.                 r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
20.                 arr = .Range("a4:d" & r)
    
21.                 For i = 1 To UBound(arr)
    
22.                     For j = 3 To 4
    
23.                         If Len(arr(i, j)) <> 0 Then
    
24.                             xm = Split(arr(i, j), "、")
    
25.                             For k = 0 To UBound(xm)
    
26.                                 If d.exists(xm(k)) Then
    
27.                                     m = d(xm(k))
    
28.                                     brr(m, j + 5) = brr(m, j + 5) + 1 / (UBound(xm) + 1)
    
29.                                 Else
    
30.                                     d1(xm(k)) = Empty
    
31.                                 End If
    
32.                             Next
    
33.                         End If
    
34.                     Next
    
35.                 Next
    
36.             End With
    
37.         End If
    
38.     Next
    
39.     With Worksheets("汇总")
    
40.         .Range("a3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
41.         .Range("w2:w" & .Rows.Count).ClearContents
    
42.         If d1.Count > 0 Then
    
43.             .Range("w2").Resize(d1.Count, 1) = Application.Transpose(d1.keys)
    
44.         End If
    
45.     End With
    
46. End Sub
    

复制代码

chxw68

看楼主经常写一些成绩分析的代码，这个简单问题楼主自己应该会吧。

sunshuangzhong

哎，最近二年失眠，脑子不好使了。只能求助了。谢谢褚老师。待会验证下！

sunshuangzhong

以前学习你的各种成绩分析代码，自己在你的代码基础上写了一个单机成绩系统，还是蛮方便的。再次感谢褚老师！

z865593849

纯数组写了个

sunshuangzhong

经验证，费用完全正确！再次感谢！

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.13
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set Sh = ThisWorkbook.Sheets("汇总")
   
5.     For Each Sht In Sheets
   
6.         If Sht.Name <> Sh.Name Then
   
7.             With Sht
   
8.                 r = .Cells(Rows.Count, "a").End(3).Row
   
9.                 arr = .[a1].Resize(r, 4)
   
10.             End With
    
11.             For j = 3 To UBound(arr, 2)
    
12.                 For i = 3 To UBound(arr)
    
13.                     If arr(i, j) <> Empty Then
    
14.                         If InStr(arr(i, j), "、") Then
    
15.                             b = Split(arr(i, j), "、")
    
16.                             For x = 0 To UBound(b)
    
17.                                 s = b(x) & "|" & (j - 2)
    
18.                                 d(s) = d(s) + 0.5
    
19.                             Next
    
20.                         Else
    
21.                             s = arr(i, j) & "|" & (j - 2)
    
22.                             d(s) = d(s) + 1
    
23.                         End If
    
24.                     End If
    
25.                 Next
    
26.             Next
    
27.         End If
    
28.     Next
    
29.     With Sh
    
30.         r = .Cells(Rows.Count, "a").End(3).Row
    
31.         arr = .[a1].Resize(r, 10)
    
32.         For i = 3 To UBound(arr)
    
33.             For j = 8 To 9
    
34.                 s = arr(i, 2) & "|" & (j - 7)
    
35.                 If d.exists(s) Then .Cells(i, j) = d(s)
    
36.             Next
    
37.             .Cells(i, 10) = Application.Sum(.Cells(i, 8).Resize(, 2))
    
38.         Next
    
39.         ActiveWindow.DisplayZeros = False
    
40.     End With
    
41.     Set d = Nothing
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "OK！"
    
44. End Sub
    

复制代码

翁知江安

Sub tj90()
Dim i, j, k, s1, s2, n, p, q, r, irow, irow1, irow2
Dim tepar, ar, br, cr, dr, er
Dim t
t = Timer
Dim d1, d2, d3, d4, d5, d6 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")
Set d5 = CreateObject("scripting.dictionary")
Set d6 = CreateObject("scripting.dictionary")
irow1 = Sheets("汇总").[q65536].End(xlUp).Row
dr = Sheets("汇总").Range("q1:r" & irow1)
   For p = 2 To irow1
     d1(dr(p, 1)) = dr(p, 2)
Next
irow2 = Sheets("汇总").[t65536].End(xlUp).Row
er = Sheets("汇总").Range("t1:u" & irow2)
   For q = 2 To irow2
     d2(er(q, 1)) = er(q, 2)
Next
For i = 1 To Sheets.Count
  If Sheets(i).Name <> "汇总" Then
    irow = Sheets(i).[b65536].End(xlUp).Row
    tepar = Sheets(i).Range("a1:d" & irow)
    For j = 4 To irow
      If tepar(j, 3) <> "" Then
       If InStr(tepar(j, 3), "、") <> 0 Then
         s1 = Left(tepar(j, 3), 4)
         s2 = Right(tepar(j, 3), 4)
         d3(s1) = d1(Left(tepar(j, 2), 2))
         d5(s1) = d5(s1) + 0.5
         d3(s2) = d1(Left(tepar(j, 2), 2))
         d5(s2) = d5(s2) + 0.5
         Else
         d3(tepar(j, 3)) = d1(Left(tepar(j, 2), 2))
         d5(tepar(j, 3)) = d5(tepar(j, 3)) + 1
        End If
       End If
      If tepar(j, 4) <> "" Then
         d4(tepar(j, 4)) = d2(Left(tepar(j, 2), 2))
         d6(tepar(j, 4)) = d6(tepar(j, 4)) + 1
      End If
Next
End If
Next
ReDim br(1 To 1000, 1 To 5)
r = Sheets("汇总").[a65536].End(xlUp).Row
  cr = Sheets("汇总").Range("a1:j" & r)
For k = 3 To r
   n = n + 1
  br(n, 1) = d3(cr(k, 2))
  br(n, 3) = d5(cr(k, 2))
  br(n, 2) = d4(cr(k, 2))
  br(n, 4) = d6(cr(k, 2))
  br(n, 5) = br(n, 1) * br(n, 3) + br(n, 2) * br(n, 4)
Next
Sheets("汇总").[f3].Resize(1000, 5).ClearContents
Sheets("汇总").[f3].Resize(n, 5) = br
MsgBox Timer - t
End Sub