1-12月工资表汇总

mfx780425

请论坛老师修改代码，按附件汇总出勤天数，应发工资，实发工资3列数据

ykcbf1100

你这个和5月26日那个差不多啊。

ykcbf1100

是这个意思吧。

汇总表标题要自己做的。

mfx780425

ykcbf1100 发表于 2022-5-30 14:43
是这个意思吧。

汇总表标题要自己做的。

谢谢ykcbf110老师的出手相助，因为打印的问题，所以汇总3列数据就可以，谢谢

ZHLK

哪有你们这样做统计表的？

chxw68

1. Sub test()
   
2.   Dim r%, i%, c1%, c2%, c3%
   
3.   Dim arr, brr, x(1 To 3) As Byte, bt() As String
   
4.   Dim ws As Worksheet
   
5.   Dim d As Object
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Set d_ws = CreateObject("scripting.dictionary")
   
8.   For Each ws In Worksheets
   
9.     If ws.Name Like "*月" Then
   
10.       d_ws(ws.Name) = Empty
    
11.     End If
    
12.   Next
    
13.   ls = 4 + d_ws.Count * 3
    
14.   n = 2
    
15.   s = 0
    
16.   ReDim bt(1 To d_ws.Count)
    
17.   For k = 1 To 12
    
18.     If d_ws.exists(k & "月") Then
    
19.       s = s + 1
    
20.       n = n + 3
    
21.       With Worksheets(k & "月")
    
22.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
23.         c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
24.         arr = .Range("a1").Resize(r, c)
    
25.         bt(s) = arr(1, 1)
    
26.         Erase x
    
27.         For j = 1 To UBound(arr, 2)
    
28.           If arr(3, j) = "出勤天数" Then
    
29.             x(1) = j
    
30.           ElseIf arr(2, j) = "应发金额" Then
    
31.             x(2) = j
    
32.           ElseIf arr(2, j) = "实发金额" Then
    
33.             x(3) = j
    
34.           End If
    
35.         Next
    
36.         If x(1) <> 0 And x(2) <> 0 And x(3) <> 0 Then
    
37.           For i = 4 To UBound(arr)
    
38.             If Len(arr(i, 4)) <> 0 Then
    
39.               If Not d.exists(arr(i, 4)) Then
    
40.                 ReDim brr(1 To ls)
    
41.                 For j = 1 To 4
    
42.                   brr(j) = arr(i, j)
    
43.                 Next
    
44.               Else
    
45.                 brr = d(arr(i, 4))
    
46.               End If
    
47.               brr(n) = arr(i, x(1))
    
48.               brr(n + 1) = arr(i, x(2))
    
49.               brr(n + 2) = arr(i, x(3))
    
50.               d(arr(i, 4)) = brr
    
51.             End If
    
52.           Next
    
53.         End If
    
54.       End With
    
55.     End If
    
56.   Next
    
57.   With Worksheets("汇总")
    
58.     .Cells.Clear
    
59.     With .Range("a1")
    
60.       .Value = "基本项目"
    
61.       .Resize(1, 4).Merge
    
62.     End With
    
63.     .Range("a2:d2") = Array("序号", "部门", "姓名", "身份证号码")
    
64.     n = 5
    
65.     For k = 1 To UBound(bt)
    
66.       With .Cells(1, n)
    
67.         .Value = bt(k)
    
68.         .Resize(1, 3).Merge
    
69.       End With
    
70.       .Cells(2, n).Resize(1, 3) = Array("出勤天数", "应发金额", "实发金额")
    
71.       n = n + 3
    
72.     Next
    
73.    
    
74.     .Range("a3").Resize(d.Count, ls) = Application.Transpose(Application.Transpose(d.items))
    
75.     With .Range("a1").Resize(2 + d.Count, ls)
    
76.       .Borders.LineStyle = xlContinuous
    
77.       With .Font
    
78.         .Name = "微软雅黑"
    
79.         .Size = 10
    
80.       End With
    
81.     End With
    
82.     With .UsedRange
    
83.       .HorizontalAlignment = xlCenter
    
84.       .VerticalAlignment = xlCenter
    
85.     End With
    
86.   End With
    
87. End Sub
    

复制代码

chxw68

表头自动生成，要汇总的项目可以在任意一列，位置也不要求一致。

mfx780425

chxw68 发表于 2022-5-30 18:51
表头自动生成，要汇总的项目可以在任意一列，位置也不要求一致。

谢谢chxw68老师，通用性极强，谢谢

ZHLK

Private Sub CommandButton1_Click()

Dim arr, brr, crr, dic, dic1, i, j, m, a, tm, k, t
Dim str1, str2 As String

Application.DisplayAlerts = False
Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    Set dic1 = CreateObject("scripting.dictionary")
    '清空汇总表
    With Sheets("汇总")
        .Activate
        .Rows("4:65536").Delete
        .Columns("E:IV").Delete
    End With
    For i = 1 To 12
        Range(Cells(2, 5 + (i - 1) * 3), Cells(2, 5 + (i - 1) * 3 + 2)).Merge
        Cells(2, 5 + (i - 1) * 3).Value = "2022年" & i & "月"
        dic1(i & "月") = 5 + (i - 1) * 3
        Cells(3, 5 + (i - 1) * 3) = "出勤天数"
        Cells(3, 5 + (i - 1) * 3 + 1) = "应发金额"
        Cells(3, 5 + (i - 1) * 3 + 2) = "实发金额"
    Next i
   
    Cells.EntireColumn.AutoFit
   
    For Each sht In Worksheets
        If InStr(sht.Name, "月") Then
            tm = Split(sht.Name, "月")(0)
            If Val(tm) > a Then a = Val(tm)
            arr = sht.Range("a1").CurrentRegion
            For i = 4 To UBound(arr) - 1
                str1 = Join(Array(arr(i, 2), arr(i, 3), arr(i, 4)), "|")
                str2 = sht.Name & "|" & Join(Array(arr(i, 5), arr(i, 15), arr(i, 22)), "|")
'                Debug.Print str1 & "-----" & str2
                If Not dic.Exists(str1) Then
                    dic(str1) = str2
                Else
                    dic(str1) = dic(str1) & "," & str2
                End If
            Next
        End If
    Next
    arr = dic.keys
    brr = dic.items
    a = 4
    For x = 0 To dic.Count - 1
        Cells(a, 1) = x + 1
        Cells(a, 2).Value = Split(arr(x), "|")(0)
        Cells(a, 3).Value = Split(arr(x), "|")(1)
        Cells(a, 4).Value = Split(arr(x), "|")(2)
        crr = Split(brr(x), ",")
        For j = 0 To UBound(crr)
            k = dic1(Split(crr(j), "|")(0))
            Cells(a, k).Value = Split(crr(j), "|")(1)
            Cells(a, k + 1).Value = Split(crr(j), "|")(2)
            Cells(a, k + 2).Value = Split(crr(j), "|")(3)
        Next j
    a = a + 1
    Next
    Set dic = Nothing
    Set dic1 = Nothing
i = Range("A65536").End(xlUp).Row
Range("A" & i & ":D" & i).VerticalAlignment = xlCenter
Range("A" & i & ":D" & i).Merge
Range("A" & i).FormulaR1C1 = "合计"
Range("F" & i).FormulaR1C1 = "=SUM(R[-5]C:R[-1]C)"
Range("F" & i).AutoFill Destination:=Range("F" & i & ":G" & i), Type:=xlFillDefault
Range("E" & i & ":G" & i).AutoFill Destination:=Range("E" & i & ":AN" & i), Type:=xlFillDefault
   
Cells.EntireColumn.AutoFit
   
Range(Cells(2, 1), Cells(Range("A65536").End(xlUp).Row, Range("AV3").End(xlToLeft).Column)).Borders.LineStyle = 1
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

mfx780425

ZHLK 发表于 2022-5-31 15:07
Private Sub CommandButton1_Click()

Dim arr, brr, crr, dic, dic1, i, j, m, a, tm, k, t

谢谢ZHLK老师，又学习了一种方法，谢谢