课时统计并形成新表

xmgslx123

老师们：在我附件里有原表和增减表数据，如何用宏来统计各位老师实际课时，最好能否有个窗口界面录入

xmgslx123

等待等待，老师们帮忙帮忙

feiren228

xmgslx123 发表于 2015-6-1 14:45
等待等待，老师们帮忙帮忙

其实用窗体就是累赘，直接在增减表里录如不行吗？

xmgslx123

也可以，一键完成，不知道宏怎么写

xmgslx123

feiren228 发表于 2015-6-1 15:18
其实用窗体就是累赘，直接在增减表里录如不行吗？

也可以，一键完成，不知道宏怎么写，大师帮忙

feiren228

xmgslx123 发表于 2015-6-1 15:39
也可以，一键完成，不知道宏怎么写，大师帮忙

增减课时是根据增减表里的数据来的？？

xmgslx123

feiren228 发表于 2015-6-1 15:48
增减课时是根据增减表里的数据来的？？

是的，一个月增加的、减少的，都录在里面

xmgslx123

xmgslx123 发表于 2015-6-1 15:51
是的，一个月增加的、减少的，都录在里面

员工的人数近500人  附件只列举30多人

xmgslx123

xmgslx123 发表于 2015-6-1 15:53
员工的人数近500人  附件只列举30多人

不好意思，应该附件里实际课时=原表K列总计-增减表F增减课时

feiren228

xmgslx123 发表于 2015-6-1 16:00
不好意思，应该附件里实际课时=原表K列总计-增减表F增减课时

请测试》》》

1. Sub aa()
   
2.     Application.ScreenUpdating = False
   
3.     Dim arr, brr, crr(), r&, i&, j%
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With Sheets("原表1")
   
6.         r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row '计算工作表最后一个非空行号
   
7.         arr = .Range("a2:o" & r)
   
8.         For i = 1 To UBound(arr)
   
9.             d(arr(i, 1)) = i
   
10.         Next
    
11.     End With
    
12.     With Sheets("增减表")
    
13.         r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row '计算工作表最后一个非空行号
    
14.         brr = .Range("a2:g" & r)
    
15.         For i = 1 To UBound(brr)
    
16.             arr(d(brr(i, 1)), 6) = brr(i, 6): arr(d(brr(i, 1)), 7) = brr(i, 7)
    
17.         Next
    
18.     End With
    
19.     ReDim crr(1 To UBound(arr) + 1, 1 To 3)
    
20.     crr(1, 1) = "行政编号": crr(1, 2) = "教师名称": crr(1, 3) = "实际课时"
    
21.     For i = 1 To UBound(arr)
    
22.         arr(i, 5) = arr(i, 10) + arr(i, 6)
    
23.         crr(i + 1, 1) = arr(i, 1): crr(i + 1, 2) = arr(i, 2): crr(i + 1, 3) = arr(i, 5)
    
24.     Next
    
25.     With Sheets("结果导出")
    
26.         Sheet3.UsedRange.ClearContents
    
27.         .[a1].Resize(UBound(crr), 3) = crr
    
28.     End With
    
29.     With Sheets("原表1")
    
30.         r = .Cells.Find("*", Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row '计算工作表最后一个非空行号
    
31.         .Range("a2:o" & r) = arr
    
32.     End With
    
33.     Set d = Nothing
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码