遍历汇总

ddz79101

ykcbf1100 发表于 2024-9-19 16:58
你的工作和我以前的工作很类似，我以前是做业务考核的。

这样！怪不得老师理解题目快。只是老师以前可以自力更生，我却不行，网上讨教。谢谢老师多次相助。

ykcbf1100

ddz79101 发表于 2024-9-19 17:16
这样！怪不得老师理解题目快。只是老师以前可以自力更生，我却不行，网上讨教。谢谢老师多次相助。

慢慢来吧，水平肯定会提高

cyq4896

参与学习一下..

Qs18

1. Sub qs()
   
2. Application.DisplayAlerts = False: Application.ScreenUpdating = False
   
3. Dim arr, i, dic, sht As Worksheet
   
4. Set dic = CreateObject("scripting.dictionary")
   
5. ReDim brr(1 To 10000, 1 To 100)
   
6. brr(1, 1) = "姓名"
   
7. m = 2: c2 = 2: c3 = 3: c4 = 4
   
8. For Each sht In Sheets
   
9.     If sht.Name <> "汇总" Then
   
10.          x = x + 1
    
11.             arr = sht.UsedRange.Value
    
12.             dic.RemoveAll
    
13.             For i = 3 To UBound(arr) - 1
    
14.                 dic(arr(i, 2)) = Array(arr(i, 8), arr(i, 12), arr(i, 13))
    
15.             Next
    
16.       
    
17.         If x = 1 Then
    
18.             cl = 1
    
19.             brr(1, 2) = sht.Name
    
20.             brr(2, 2) = "单位": brr(2, 3) = "个人": brr(2, 4) = "合计"
    
21.             For Each k In dic.keys
    
22.             m = m + 1
    
23.            
    
24.             brr(m, 1) = k
    
25.             brr(m, 2) = dic(k)(0)
    
26.             brr(m, 3) = dic(k)(1)
    
27.             brr(m, 4) = dic(k)(2)
    
28.             Next
    
29.         Else
    
30.             c2 = c2 + 3: c3 = c3 + 3: c4 = c4 + 3
    
31.             brr(2, c2) = "单位": brr(2, c3) = "个人": brr(2, c4) = "合计"
    
32.             brr(1, c2) = sht.Name
    
33.                 For i = 3 To m
    
34.                     If dic.exists(brr(i, 1)) Then
    
35.                     brr(i, c2) = dic(brr(i, 1))(0)
    
36.                     brr(i, c3) = dic(brr(i, 1))(1)
    
37.                     brr(i, c4) = dic(brr(i, 1))(2)
    
38.                     dic.Remove brr(i, 1)
    
39.                     End If
    
40.                 Next
    
41.                 If dic.Count > 0 Then '新来的员工
    
42.                    For Each k2 In dic.keys
    
43.                     m = m + 1
    
44.                     brr(m, 1) = k2
    
45.                     brr(m, c2) = dic(k2)(0)
    
46.                     brr(m, c3) = dic(k2)(1)
    
47.                     brr(m, c4) = dic(k2)(2)
    
48.                    Next
    
49.                 End If
    
50.         End If
    
51.     End If
    
52. Next
    
53. ReDim crr(1 To m, 1 To 3)
    
54. crr(1, 1) = "合计": crr(2, 1) = "单位": crr(2, 2) = "个人": crr(2, 3) = "合计"
    
55. For i = 3 To m
    
56.     For j = 2 To c2 Step 3
    
57.         crr(i, 1) = crr(i, 1) + brr(i, j)
    
58.         crr(i, 2) = crr(i, 2) + brr(i, j + 1)
    
59.         crr(i, 3) = crr(i, 3) + brr(i, j + 2)
    
60.     Next
    
61. Next
    
62. Set dic = Nothing
    
63. With Sheet1
    
64.     .Range("a1:s10000").Clear
    
65.     .Range("a1").Resize(m, c4) = brr
    
66.     .Range("a1").Offset(, c4).Resize(m, 3) = crr
    
67.     .Range(.Cells(m + 1, 2), .Cells(m + 1, c4 + 3)).Formula = "=sum(b3:b" & m & ")"
    
68.     .Cells(m + 1, 1) = "合计"
    
69.     .Range("a1:a2").Merge
    
70. For cc = 2 To 100 Step 3
    
71.     If Len(.Cells(1, cc)) > 0 Then
    
72.         .Cells(1, cc).Resize(1, 3).Merge
    
73.     End If
    
74. Next
    
75.    With .Range("a1").CurrentRegion
    
76.    .Borders.LineStyle = 1
    
77.     .HorizontalAlignment = xlCenter
    
78.     .Columns.AutoFit
    
79.     .Value = .Value
    
80.     End With
    
81. End With
    
82. Application.DisplayAlerts = True: Application.ScreenUpdating = True
    
83. End Sub
    

复制代码

Qs18

试试...........

Qs18

试试...........

ddz79101

cyq4896 发表于 2024-9-22 11:30
参与学习一下..

谢谢老师！运行顺利

ddz79101

Qs18 发表于 2024-9-22 15:46
试试...........

谢谢老师！顺利完成