汇总每个月的人员数据

hhxq001

明天会更好zj 发表于 2022-4-5 19:40
这个不难，一个循环加字典就OK。

可以给写出答案吗

ykcbf1100

全年汇总，12个月汇总也没问题

ykcbf1100

1. Sub ykcbf()   '//2025.3.16
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     sh.UsedRange.Offset(2, 4) = Empty
   
6.     brr = sh.UsedRange
   
7.     For i = 3 To UBound(brr)
   
8.         If brr(i, 1) <> Empty Then d(brr(i, 1)) = i
   
9.     Next
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> sh.Name Then
    
12.             arr = sht.UsedRange
    
13.             For i = 3 To UBound(arr)
    
14.                 If d.exists(arr(i, 1)) Then
    
15.                     m = d(arr(i, 1))
    
16.                     For j = 4 To UBound(arr, 2)
    
17.                         brr(m, j + 1) = brr(m, j + 1) + arr(i, j)
    
18.                     Next
    
19.                 End If
    
20.             Next
    
21.         End If
    
22.     Next
    
23.     sh.UsedRange = brr
    
24.     Set d = Nothing
    
25.     Application.ScreenUpdating = False
    
26. End Sub
    

复制代码

Qs18

1. Sub qs()
   
2. Dim arr, i, dic, sht As Worksheet
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5.     .Range("a2").Offset(1).Resize(100000, 10000).Clear
   
6.     arr = .Range("a2").CurrentRegion
   
7.     For i = 1 To UBound(arr, 2)
   
8.         dic(arr(2, i)) = i
   
9.     Next
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> "汇总" Then
    
12.             arr = sht.Range("a1").CurrentRegion.Value
    
13.             For cl = 1 To UBound(arr, 2)
    
14.                 If dic.exists(arr(2, cl)) Then
    
15.                 cc = dic(arr(2, cl))
    
16.                 rw = .Cells(Rows.Count, cc).End(xlUp).Row
    
17.                     For i = 3 To UBound(arr)
    
18.                     rw = rw + 1
    
19.                     .Cells(rw, cc) = arr(i, cl)
    
20.                     Next i
    
21.                 End If
    
22.             Next cl
    
23.         End If
    
24.     Next sht
    
25. End With
    
26. Set dic = Nothing
    
27. Set sht = Nothing
    
28. MsgBox "完成汇总！"
    
29. End Sub
    

复制代码

Qs18

试试.........

Qs18

试试.......

hhxq001

ykcbf1100 发表于 2025-3-16 08:13
全年汇总，12个月汇总也没问题

你这段代码的执行，必须要先保证a列有身份证号码才行。
因为每个月的工作表里人员不同，肉眼不容易找出所有人员名单，所以才要汇总时自动找出全部人员并汇总数据

shiruiqiang

ykcbf1100 代码上修改一下，自动收集人员

顺手写个sql汇总

ykcbf1100

hhxq001 发表于 2025-3-20 15:15
你这段代码的执行，必须要先保证a列有身份证号码才行。
因为每个月的工作表里人员不同，肉眼不容易找出 ...

被你的表格误导，重写一下吧。

ykcbf1100

1. Sub ykcbf()   '//2025.3.20
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     sh.UsedRange.Offset(2) = Empty
   
6.     ReDim brr(1 To 10 ^ 4, 1 To 7)
   
7.     For Each sht In Sheets
   
8.         If sht.Name <> sh.Name Then
   
9.             arr = sht.UsedRange
   
10.             For i = 3 To UBound(arr)
    
11.                 s = arr(i, 1)
    
12.                 If Not d.exists(s) Then
    
13.                     m = m + 1
    
14.                     d(s) = m
    
15.                     brr(m, 1) = s
    
16.                     brr(m, 3) = arr(i, 3)
    
17.                     For j = 4 To UBound(arr, 2)
    
18.                         brr(m, j + 1) = arr(i, j)
    
19.                     Next
    
20.                 Else
    
21.                     r = d(s)
    
22.                     For j = 4 To UBound(arr, 2)
    
23.                         brr(r, j + 1) = brr(r, j + 1) + arr(i, j)
    
24.                     Next
    
25.                 End If
    
26.             Next
    
27.         End If
    
28.     Next
    
29.     sh.[a3].Resize(m, 7) = brr
    
30.     Set d = Nothing
    
31.     Application.ScreenUpdating = False
    
32. End Sub
    

复制代码