麻烦大神，将任意月到月工资按人名汇总

wcj6376tcp

麻烦大神，将任意月到月工资按人名汇总，其中可能会出现退休，新增人员，人名位置不一定一一对应，实现汇总表效果，谢谢！

wcj6376tcp

wcj6376tcp

人数很多，表中近为例子

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.25
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("汇总")
   
7.     yf1 = Val(sh.[k1]): yf2 = Val(sh.[m1])
   
8.     For Each sht In Sheets
   
9.         If sht.Name <> sh.Name Then
   
10.             fn = Val(sht.Name)
    
11.             If fn >= yf1 And fn <= yf2 Then
    
12.                 With sht
    
13.                     r = .Cells(Rows.Count, 1).End(3).Row
    
14.                     arr = .Range("a1:aa" & r)
    
15.                     For i = 4 To UBound(arr)
    
16.                         For j = 4 To UBound(arr, 2)
    
17.                             s = arr(i, 3) & "|" & arr(3, j)
    
18.                             d(s) = d(s) + arr(i, j)
    
19.                             s = arr(i, 3)
    
20.                             If Not d1.exists(s) Then
    
21.                                 d1(s) = sht.Name
    
22.                             Else
    
23.                                 d1(s) = IIf(InStr(d1(s), sht.Name), d1(s), d1(s) & " " & sht.Name)
    
24.                             End If
    
25.                         Next
    
26.                     Next
    
27.                 End With
    
28.             End If
    
29.         End If
    
30.     Next
    
31.     With sh
    
32.         r = .Cells(Rows.Count, 1).End(3).Row
    
33.         .[b4:z1000] = ""
    
34.         arr = .Range("a1:z" & r)
    
35.         For i = 4 To UBound(arr)
    
36.             For j = 2 To UBound(arr, 2) - 1
    
37.                 s = arr(i, 1) & "|" & arr(3, j)
    
38.                 If d.exists(s) Then
    
39.                     arr(i, j) = d(s)
    
40.                 End If
    
41.             Next
    
42.             s = arr(i, 1)
    
43.             If d1.exists(s) Then
    
44.                 arr(i, UBound(arr, 2)) = d1(s)
    
45.             Else
    
46.                 arr(i, UBound(arr, 2)) = ""
    
47.             End If
    
48.         Next
    
49.         .Range("a1:z" & r) = arr
    
50.     End With
    
51.     Set d = Nothing
    
52.     Application.ScreenUpdating = True
    
53.     MsgBox "OK！"
    
54. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

wcj6376tcp

ykcbf1100 发表于 2024-1-25 20:54
附件供参考。。。

谢谢老师，新增甲11会没有任何数据，如果手动清除汇总表后，不会出现任何数据，麻烦老师再看看看，谢谢！

ykcbf1100

wcj6376tcp 发表于 2024-1-25 21:50
谢谢老师，新增甲11会没有任何数据，如果手动清除汇总表后，不会出现任何数据，麻烦老师再看看看，谢谢！

甲11是12月份开始才有数据的，你必须选择12为截止时间才可以。

wcj6376tcp

ykcbf1100 发表于 2024-1-25 22:10
甲11是12月份开始才有数据的，你必须选择12为截止时间才可以。

现在问题是我如果手动清除了汇总表a4以下的数据后，哪怕在k1 m1 输入任何月份运行就只提示OK？

ykcbf1100

wcj6376tcp 发表于 2024-1-25 22:42
现在问题是我如果手动清除了汇总表a4以下的数据后，哪怕在k1 m1 输入任何月份运行就只提示OK？

你的意思是姓名列也要自动生成？
改好了。。。

另外，a4以下区域代码在汇总前会自动帮你先清空的，不用手工清除。

wcj6376tcp

ykcbf1100 发表于 2024-1-26 08:37
你的意思是姓名列也要自动生成？
改好了。。。

谢谢！就是需要这种效果，太厉害了!方便以后季报工资。在老师的基础上修改了一下。

Sub ykcbf()  '//2024.1.25
    Dim arr, brr, d
    Dim Miny, Maxy, Rs As Long
    Dim T As Date
    T = Timer
   
    Miny = InputBox("请输入要汇总的起始月份：", "输入起始月份数...", "1")
    Maxy = InputBox("请输入要汇总的终止月份：", "输入终止月份数...", "12")
    Range("K1").Value = Miny
    Range("M1").Value = Maxy
    Range("V1").Value = "=NOW()" '当前时间
    Cells(1, 22) = Cells(1, 22).Value '记录汇总时间
   
    'Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set sh = ThisWorkbook.Sheets("汇总")
    yf1 = Val(sh.[K1]): yf2 = Val(sh.[M1])
    For Each sht In Sheets
        If sht.Name <> sh.Name Then
            fn = Val(sht.Name)
            If fn >= yf1 And fn <= yf2 Then
                With sht
                    r = .Cells(rows.Count, 1).End(3).Row
                    arr = .Range("A1:AA" & r)
                    For i = 4 To UBound(arr)
                        For j = 4 To UBound(arr, 2)
                            s = arr(i, 3) & "|" & arr(3, j)
                            d(s) = d(s) + arr(i, j)
                            s = arr(i, 3)
                            If Not d1.exists(s) Then
                                d1(s) = sht.Name
                            Else
                                d1(s) = IIf(InStr(d1(s), sht.Name), d1(s), d1(s) & " " & sht.Name)
                            End If
                            d2(arr(i, 3)) = ""
                        Next
                    Next
                End With
            End If
        End If
    Next
    With sh
        r = .Cells(rows.Count, 1).End(3).Row
        .[A4:Z1000] = ""
        .[A4].Resize(d2.Count, 1) = WorksheetFunction.Transpose(d2.keys)
        arr = .Range("A1:Z" & r)
        For i = 4 To UBound(arr)
            For j = 2 To UBound(arr, 2) - 1
                s = arr(i, 1) & "|" & arr(3, j)
                If d.exists(s) Then
                    arr(i, j) = d(s)
                End If
            Next
            s = arr(i, 1)
            If d1.exists(s) Then
                arr(i, UBound(arr, 2)) = d1(s)
            Else
                arr(i, UBound(arr, 2)) = ""
            End If
        Next
        .Range("A1:Z" & r) = arr
    End With
    Set d = Nothing
    'Application.ScreenUpdating = True
    Rs = Sheets("汇总").Range("A3").CurrentRegion.rows.Count - 4 '获取行数
    MsgBox "汇总" & Miny & "-" & Maxy & "月数据完毕!用时 " & Format((Timer - T), "0.0000") & " 秒," & vbCrLf & "共汇总 " & Rs & " 个人员数据。", vbInformation, ""
End Sub