根据部颁课时表和科目分担计算个人课时数

偶然古月照江北

求大神们帮助！根据部颁课时表和科目分担计算个人课时数，见附件

偶然古月照江北

难道用公式不能实现目标吗？

wjcmouse

没有怎么看懂，不过我觉得原始表要做下修改，要不后续不好加工。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   With Worksheets("sheet1")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("b20:s26")
   
10.     For i = 2 To UBound(arr)
    
11.       nj = InStr("一二三四五六七八九", arr(i, 1))
    
12.       Debug.Print nj
    
13.       Set d1(nj) = CreateObject("scripting.dictionary")
    
14.       For j = 2 To UBound(arr, 2)
    
15.         If Len(arr(i, j)) <> 0 Then
    
16.           d1(nj)(arr(1, j)) = arr(i, j)
    
17.         End If
    
18.       Next
    
19.     Next
    
20.     arr = .Range("c1:s19")
    
21.     For i = 2 To UBound(arr)
    
22.       If Len(arr(i, 1)) <> 0 Then
    
23.         nj = Val(Left(arr(i, 1), 1))
    
24.         If d1.exists(nj) Then
    
25.           For j = 2 To UBound(arr, 2)
    
26.             If d1(nj).exists(arr(1, j)) Then
    
27.               If Len(arr(i, j)) <> 0 Then
    
28.                 d(arr(i, j)) = d(arr(i, j)) + d1(nj)(arr(1, j))
    
29.               End If
    
30.             End If
    
31.           Next
    
32.         End If
    
33.       End If
    
34.     Next
    
35.     r = .Cells(.Rows.Count, 22).End(xlUp).Row
    
36.     arr = .Range("v2:x" & r)
    
37.     For i = 1 To UBound(arr)
    
38.       If d.exists(arr(i, 1)) Then
    
39.         arr(i, 3) = d(arr(i, 1))
    
40.       End If
    
41.     Next
    
42.     .Range("v2:x" & r) = arr
    
43.   End With
    
44. End Sub
    

复制代码

chxw68

详见附件。

一指禅62

1. Sub 汇总()
   
2.     Dim d As Object, dx As Object, arr, i%, j%, k
   
3.     Dim Rng As Range
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set dx = CreateObject("Scripting.Dictionary")
   
6.     Rem  提取部頒计划
   
7.     arr = Sheet1.Range("C20:R26")   '
   
8.     For i = 2 To UBound(arr)
   
9.         For j = 1 To UBound(arr, 2)
   
10.             d(arr(1, j) & "|" & i - 1) = arr(i, j)
    
11.         Next
    
12.     Next
    
13.     Rem 提取任课教师姓名
    
14.     Dim x%, x1%, a()
    
15.     For Each Rng In Sheet1.Range("V2:V" & Sheet1.Range("V65536").End(3).Row)
    
16.         If Rng.Value <> "" Then
    
17.             x = x + 1: ReDim Preserve a(1 To 2, 1 To x)
    
18.             dx(Rng.Value) = x
    
19.         End If
    
20.     Next
    
21.     Rem 汇总工作量
    
22.     arr = Sheet1.Range("C1:S19")
    
23.     For i = 2 To UBound(arr)
    
24.         For j = 2 To UBound(arr, 2)
    
25.             If arr(i, j) <> "" Then
    
26.                 k = arr(1, j) & "|" & Left(arr(i, 1), 1)
    
27.                 If Not dx.Exists(arr(i, j)) Then
    
28.                     x = x + 1: ReDim Preserve a(1 To 2, 1 To x)
    
29.                     a(1, x) = 1
    
30.                     a(2, x) = d.Item(k)
    
31.                     dx(arr(i, j)) = x
    
32.                 Else
    
33.                     x1 = dx.Item(arr(i, j))
    
34.                     a(1, x1) = a(1, x1) + 1
    
35.                     a(2, x1) = a(2, x1) + d.Item(k)
    
36.                 End If
    
37.             End If
    
38.         Next
    
39.     Next
    
40.     Sheet1.Range("W2").Resize(dx.Count, 2) = WorksheetFunction.Transpose(a)
    
41. End Sub

复制代码

一指禅62

计算个人课时数.rar (14.09 KB, 下载次数: 12)

2018-9-6 11:18 上传

点击文件名下载附件

偶然古月照江北

一指禅62 发表于 2018-9-6 11:18

谢谢，高手！但我想请教，这个计算能不能用公式来实现？这样在安排分课时能及时发现并调整

偶然古月照江北

chxw68 发表于 2018-9-6 10:58
详见附件。

谢谢老师！我想问的是能否用公式完成，这样更有利于排表中的调整

一指禅62

偶然古月照江北 发表于 2018-9-6 12:10
谢谢，高手！但我想请教，这个计算能不能用公式来实现？这样在安排分课时能及时发现并调整

随时点击刷新啊

公式函数您发错版块了。