多条件汇总统计数据

zjwsm

我有一个工资统计用的工作簿，内有历年工资数据，为了统计方便，用到多条件统计数据，需使用VBA代码，请大侠帮忙。

ykcbf1100

得写三个代码啊。

Qs18

Sub qs() '2024/6/28
Dim arr, brr, i
arr = Sheet1.UsedRange
With Sheet4
    fs = Val(.[c1].Value)
    ss = Val(.[c2].Value)
    xm = .[c3].Value
    If xm = "" Then xm = "*" & xm & "*"
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 1)
    For i = 2 To UBound(arr)
        If Val(arr(i, 1)) = fs And ss = Val(arr(i, 3)) And arr(i, 4) Like xm Then
            r = r + 1
            For j = 1 To UBound(arr, 2) - 1
                brr(r, j) = arr(i, j)
            Next
        End If
    Next
    .Range("a5:s10000").ClearContents
    .Range("a5").Resize(r, UBound(brr, 2)) = brr
End With
MsgBox "完成！"
End Sub

Qs18

试一下...............

Qs18

试一下.............

ykcbf1100

写了第一个统计。

有坑，数据表第一列年份是文本格式

zjwsm

ykcbf1100 发表于 2024-6-28 07:22
得写三个代码啊。

是阿
按姓名统计和按人员统计二张要写代码、按人员查询已有代码了。

ykcbf1100

三个统计都写好了。

ykcbf1100

按月份统计

1. Sub ykcbf2()   '//2024.6.28  按月份统计
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("数据库")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 20)
   
7.     End With
   
8.     ReDim brr(1 To UBound(arr), 1 To 100)
   
9.     m = 1: n = 1
   
10.     brr(1, 1) = "月度"
    
11.     With Sheets("按月度统计")
    
12.         For i = 2 To UBound(arr)
    
13.             If Val(arr(i, 1)) = .[b2] And Val(arr(i, 3)) = .[b3] Then
    
14.                 s = arr(i, 2)
    
15.                 If Not d.exists(s) Then
    
16.                     m = m + 1
    
17.                     d(s) = m
    
18.                     brr(m, 1) = s
    
19.                 End If
    
20.                 r = d(arr(i, 2))
    
21.                 For j = 5 To UBound(arr, 2)
    
22.                     s = arr(1, j)
    
23.                     If Not d.exists(s) Then
    
24.                         n = n + 1
    
25.                         d(s) = n
    
26.                         brr(1, n) = s
    
27.                     End If
    
28.                     c = d(arr(1, j))
    
29.                     brr(r, c) = brr(r, c) + arr(i, j)
    
30.                 Next
    
31.             End If
    
32.         Next
    
33.         .UsedRange.Offset(1, 3).Clear
    
34.         .[e1].Resize(, 26).Clear
    
35.         .[d1].Resize(1, n).Interior.Color = 49407
    
36.         With .[d1].Resize(m, n)
    
37.             .Value = brr
    
38.             .Borders.LineStyle = 1
    
39.             .HorizontalAlignment = xlCenter
    
40.             .VerticalAlignment = xlCenter
    
41.         End With
    
42.     End With
    
43.     Set d = Nothing
    
44.     Application.ScreenUpdating = True
    
45.     MsgBox "OK！"
    
46. End Sub
    
47. 
    

复制代码

ykcbf1100

按人员统计

1. Sub ykcbf3()   '//2024.6.28  按人员统计
   
2.     Application.ScreenUpdating = False
   
3.     With Sheets("数据库")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 20)
   
6.     End With
   
7.     ReDim brr(1 To UBound(arr), 1 To 100)
   
8.     m = 1
   
9.     For j = 1 To UBound(arr, 2)
   
10.         brr(1, j) = arr(1, j)
    
11.     Next
    
12.     With Sheets("按人员查询")
    
13.         xm = .[c3].Value
    
14.         fft = 0
    
15.         For i = 2 To UBound(arr)
    
16.             If Val(arr(i, 1)) = .[c1] And Val(arr(i, 3)) = .[c2] Then
    
17.                 If xm = "" Or arr(i, 4) = xm Then fft = 1
    
18.                 If fft = 1 Then
    
19.                     m = m + 1
    
20.                     For j = 1 To UBound(arr, 2)
    
21.                         brr(m, j) = arr(i, j)
    
22.                     Next
    
23.                 End If
    
24.             End If
    
25.         Next
    
26.         .UsedRange.Offset(3).Clear
    
27.         .[a4].Resize(1, 20).Interior.Color = 49407
    
28.         With .[a4].Resize(m, 20)
    
29.             .Value = brr
    
30.             .Borders.LineStyle = 1
    
31.             .HorizontalAlignment = xlCenter
    
32.             .VerticalAlignment = xlCenter
    
33.         End With
    
34.     End With
    
35.     Set d = Nothing
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "OK！"
    
38. End Sub
    

复制代码