[已解决]汇总“考勤汇总表”（VBA）

long826121

首先非常感谢各位兄弟姐妹帮我！
要求：点击“汇总表”中的“汇总”按钮，汇总出“汇总表”后面所有表中各人的考勤情况。
           点击“汇总表”中的“清除”按钮，清除汇总表所有人的姓名和考勤情况。 2016年教师考勤表.rar (6.75 KB, 下载次数: 77)

2016-11-30 19:16 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

苏子龙

2016-12-1 08:44

1. Sub tt() '学习裙子老师教的字典套字典方法
   
2.     Dim d As Object, i%, sh As Worksheet
   
3.     Dim stmArr, rw%
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For Each sh In Worksheets
   
6.         If sh.Name <> "汇总表" Then
   
7.         stmArr = sh.Range("a4:y" & sh.[a65536].End(3).Row)
   
8.         For i = 2 To UBound(stmArr)
   
9.             For n = 2 To UBound(stmArr, 2)
   
10.                 If Not d.exists(stmArr(i, 1)) Then
    
11.                     Set d(stmArr(i, 1)) = CreateObject("scripting.dictionary")
    
12.                 End If
    
13.                 d(stmArr(i, 1))(n) = d(stmArr(i, 1))(n) + stmArr(i, n)
    
14.         Next n, i
    
15.         End If
    
16.     Next
    
17.     Range("a5").Resize(d.Count) = Application.Transpose(d.keys)
    
18.     Do
    
19.         Cells(5 + rw, 2).Resize(, 24) = d(Cells(5 + rw, 1).Value).items
    
20.         rw = rw + 1
    
21.     Loop Until Cells(5 + rw, 1).Value = ""
    
22. End Sub
    
23. Sub del()
    
24.     Range("a5:y65536").ClearContents
    
25. End Sub

复制代码

跳转到最佳答案楼层

Excel学徒123

论坛这种实例不少的哦，仔细找找

苏子龙

关注下，用字典吗

苏子龙

1. Sub tt() '学习裙子老师教的字典套字典方法
   
2.     Dim d As Object, i%, sh As Worksheet
   
3.     Dim stmArr, rw%
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For Each sh In Worksheets
   
6.         If sh.Name <> "汇总表" Then
   
7.         stmArr = sh.Range("a4:y" & sh.[a65536].End(3).Row)
   
8.         For i = 2 To UBound(stmArr)
   
9.             For n = 2 To UBound(stmArr, 2)
   
10.                 If Not d.exists(stmArr(i, 1)) Then
    
11.                     Set d(stmArr(i, 1)) = CreateObject("scripting.dictionary")
    
12.                 End If
    
13.                 d(stmArr(i, 1))(n) = d(stmArr(i, 1))(n) + stmArr(i, n)
    
14.         Next n, i
    
15.         End If
    
16.     Next
    
17.     Range("a5").Resize(d.Count) = Application.Transpose(d.keys)
    
18.     Do
    
19.         Cells(5 + rw, 2).Resize(, 24) = d(Cells(5 + rw, 1).Value).items
    
20.         rw = rw + 1
    
21.     Loop Until Cells(5 + rw, 1).Value = ""
    
22. End Sub
    
23. Sub del()
    
24.     Range("a5:y65536").ClearContents
    
25. End Sub

复制代码

long826121

苏子龙 发表于 2016-12-1 08:44

非常感谢

雄鹰2013

Sub 汇总() '雄鹰2017.12.1
Dim tt
Set d = CreateObject("scripting.dictionary")
For k = 1 To Sheets.Count
     arr = Sheets(k).[a1].CurrentRegion
     For j = 2 To UBound(arr, 2)
         If arr(3, j) = "" Then arr(3, j) = arr(3, j - 1)
     Next j
     If k = 1 Then brr = arr
     ReDim crr(1 To UBound(brr) - 4, 1 To UBound(brr) - 1)
     If k <> 1 Then
        For i = 5 To UBound(arr)
            For j = 2 To UBound(arr, 2)
                tt = arr(i, 1) & arr(3, j) & arr(4, j)
                d(tt) = d(tt) + arr(i, j)
            Next j
        Next i
     End If
Next k
For i = 5 To UBound(brr)
     For j = 2 To UBound(brr, 2)
         tt = brr(i, 1) & brr(3, j) & brr(4, j)
         crr(i - 4, j - 1) = d(tt)
     Next j
Next i
Sheet1.[b5].Resize(UBound(crr), UBound(crr, 2)) = crr
End Sub