用vba代码统计总数

adud

3190496160

若“每月表”人员中出现“统计”表中没有的人员，则认为是新近人员，需要在“统计”表中添加该人员，并统计违纪情况
所有人员信息直接从每月表中获取不行吗？？

3190496160

Sub 统计()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long, r As Long, rs As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("统计")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r > 1 Then .Range("a2:l" & r) = Empty
    ar = .Range("a1:l5000")
    For j = 4 To UBound(ar, 2)
        If Trim(ar(1, j)) <> "" Then
            d(Trim(ar(1, j))) = j
        End If
    Next j
    k = 1
    For Each sh In Sheets
        If InStr(sh.Name, "月") > 0 Then
            rs = sh.Cells(Rows.Count, 1).End(xlUp).Row
            y = sh.Cells(1, Columns.Count).End(xlToLeft).Column
            br = sh.Range(sh.Cells(1, 1), sh.Cells(rs, y))
            For i = 2 To UBound(br)
                If Trim(br(i, 2)) <> "" Then
                    t = d(Trim(br(i, 2)))
                    If t = "" Then
                        k = k + 1
                        d(Trim(br(i, 2))) = k
                        t = k
                        For j = 1 To 3
                            ar(k, j) = br(i, j)
                        Next j
                    End If
                    For j = 4 To y
                        If Trim(br(i, j)) <> "" Then
                            If InStr(br(i, j), "*") = 0 Then
                                sl = Len(Trim(br(i, j)))
                                For s = 1 To sl
                                    zf = Mid(Trim(br(i, j)), s, 1)
                                    If IsNumeric(zf) Then
                                        lh = s
                                        Exit For
                                    End If
                                Next s
                                mc = Left(Trim(br(i, j)), lh - 1)
                                cs = Val(Right(Trim(br(i, j)), sl - lh + 1))
                                llh = d(Trim(mc))
                                If llh <> "" Then
                                    ar(t, llh) = ar(t, llh) + cs
                                End If
                            Else
                                rr = Split(br(i, j), "*")
                                For s = 0 To UBound(rr)
                                    sl = Len(Trim(rr(s)))
                                    For ss = 1 To sl
                                        zf = Mid(Trim(rr(s)), ss, 1)
                                        If IsNumeric(zf) Then
                                            lh = ss
                                            Exit For
                                        End If
                                    Next ss
                                    mc = Left(Trim(rr(s)), lh - 1)
                                    cs = Val(Right(Trim(rr(s)), sl - lh + 1))
                                    llh = d(Trim(mc))
                                    If llh <> "" Then
                                        ar(t, llh) = ar(t, llh) + cs
                                    End If
                                Next s
                            End If
                        End If
                    Next j
                End If
            Next i
        End If
    Next sh
    .[a1].Resize(k, UBound(ar, 2)) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

人员统计表.rar (27.27 KB, 下载次数: 31)

2023-7-6 09:21 上传

点击文件名下载附件

3190496160

结果为核对，代码仅供参考，

adud

3190496160 发表于 2023-7-6 09:22
结果为核对，代码仅供参考，

谢谢大佬的帮助，我来看看怎么样。

adud

正是我需要的，这么复杂的问题都能完美解决，真是太棒了！

adud

3190496160 发表于 2023-7-6 08:47
若“每月表”人员中出现“统计”表中没有的人员，则认为是新近人员，需要在“统计”表中添加该人员，并统计 ...

实际是之前已经有一些数据记录，需要追加数据，若是直接从每月表中获取，之前的违纪记录就没了。或者说这次统计到3月，后面还有4、5、6.。。。。的数据需要统计进来。不过有你的这个，我可以自己试着改一下。争取在不清空原来数据的基础上累计以后的。

grf1973

小改了一下3楼的代码，用正则查找违规类型和次数。

1. Sub 统计()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     With Sheets("统计")
   
4.         .[a2:l5000] = ""
   
5.         ar = .Range("a1:l5000")
   
6.         For j = 4 To UBound(ar, 2)   '违规类型对应的列
   
7.             If Trim(ar(1, j)) <> "" Then d(Trim(ar(1, j))) = j
   
8.         Next j
   
9.         k = 1
   
10.         
    
11.         With CreateObject("vbscript.regexp")
    
12.             .Global = True
    
13.             .Pattern = "([\u4e00-\u9fa5]+)(\d+)"   '找到 “迟到1”这种内容
    
14.             For Each sh In Sheets
    
15.                 If InStr(sh.Name, "月") > 0 Then
    
16.                     br = sh.[a1].CurrentRegion
    
17.                     For i = 2 To UBound(br)
    
18.                         x = Trim(br(i, 2))
    
19.                         If x <> "" Then
    
20.                             If Not d.exists(x) Then
    
21.                                 k = k + 1
    
22.                                 d(x) = k
    
23.                                 For j = 1 To 3: ar(k, j) = br(i, j): Next j
    
24.                             End If
    
25.                             p = d(x)
    
26.                             For j = 4 To UBound(br, 2)
    
27.                                 s = Trim(br(i, j))
    
28.                                 If .test(s) <> "" Then
    
29.                                     For Each m In .Execute(s)
    
30.                                         lx = m.submatches(0)   '违规类型
    
31.                                         cs = Val(m.submatches(1))   '违规次数
    
32.                                         c = d(lx)
    
33.                                         If c > 0 Then ar(p, c) = ar(p, c) + cs
    
34.             Next m: End If: Next j: End If: Next i: End If: Next sh
    
35.         End With
    
36.         .[a1].Resize(k, UBound(ar, 2)) = ar
    
37.     End With
    
38.     MsgBox "ok!"
    
39. End Sub

复制代码

半百

请测试