请大神帮忙vba做一下餐费补贴的统计表格，以减轻工作量，谢谢！

烟火孤星泪

已完成，谢谢帮忙

烟火孤星泪

有大神会做吗？

一指禅62

实现“查询”在此代码基础上修改即可。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("效果")
   
5.         xm = .Range("b1")
   
6.     End With
   
7.     With Worksheets("消费明细")
   
8.         .AutoFilterMode = False
   
9.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.         arr = .Range("a2:f" & r)
    
11.     End With
    
12.     ReDim brr(1 To UBound(arr), 1 To 10)
    
13.     m = 0
    
14.     For i = 1 To UBound(arr)
    
15.         If arr(i, 3) = xm Then
    
16.             m = m + 1
    
17.             brr(m, 1) = arr(i, 3)
    
18.             brr(m, 2) = arr(i, 4)
    
19.             brr(m, 3) = DateValue(arr(i, 5))
    
20.             sj = TimeValue(arr(i, 5))
    
21.             If sj >= #5:00:00 PM# Then
    
22.                 brr(m, 4) = arr(i, 6)
    
23.                 brr(m, 8) = Application.Min(brr(m, 4), 10)
    
24.             ElseIf sj >= #11:00:00 AM# And sj <= #1:00:00 PM# Then
    
25.                 brr(m, 5) = arr(i, 6)
    
26.                 brr(m, 9) = Application.Min(brr(m, 5), 14)
    
27.             ElseIf sj >= #6:30:00 AM# And sj <= #9:00:00 AM# Then
    
28.                 brr(m, 6) = arr(i, 6)
    
29.                 brr(m, 10) = Application.Min(brr(m, 6), 5)
    
30.             End If
    
31.         End If
    
32.     Next
    
33.     With Worksheets("效果")
    
34.         .UsedRange.Offset(2, 0).ClearContents
    
35.         If m = 0 Then
    
36.             MsgBox "没有符合条件数据！"
    
37.             Exit Sub
    
38.         End If
    
39.         .Range("a3").Resize(m, UBound(brr, 2)) = brr
    
40.     End With
    
41. End Sub
    

复制代码

chxw68

详见附件。

饮冰e士

练习一下，算补贴：

3190496160

Sub 统计()
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("消费明细")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "消费明细为空！": End
    ar = .Range("a1:f" & r)
End With
Dim br()
ReDim br(1 To UBound(ar), 1 To 10)
For i = 2 To UBound(ar)
    If ar(i, 4) <> "" Then
        If IsDate(ar(i, 5)) Then
            If Not d.exists(ar(i, 3)) Then Set d(ar(i, 3)) = CreateObject("scripting.dictionary")
            d(ar(i, 3))(i) = ""
        End If
    End If
Next i
For Each k In d.keys
    dc.RemoveAll
    For Each kk In d(k).keys
        rq = CDate(Format(ar(kk, 5), "yyyy/mm/dd"))
        If Not dc.exists(rq) Then Set dc(rq) = CreateObject("scripting.dictionary")
        dc(rq)(kk) = ""
    Next kk
    For Each kc In dc.keys
        n = n + 1
        br(n, 1) = k
        br(n, 3) = kc
        For Each kkc In dc(kc).keys
            br(n, 2) = ar(kkc, 4)
            sj = Format(ar(kkc, 5), "h:mm:ss")
            If TimeValue(sj) >= TimeValue("17:00:00") Then
                br(n, 4) = Val(ar(kkc, 6))
                If Val(ar(kkc, 6)) > 10 Then
                    br(n, 8) = 10
                Else
                    br(n, 8) = Val(ar(kkc, 6))
                End If
            ElseIf TimeValue(sj) >= TimeValue("11:00:00") And TimeValue(sj) <= TimeValue("13:00:00") Then
                br(n, 5) = Val(ar(kkc, 6))
                If Val(ar(kkc, 6)) > 14 Then
                    br(n, 9) = 14
                Else
                    br(n, 9) = Val(ar(kkc, 6))
                End If
            ElseIf TimeValue(sj) >= TimeValue("6:30:00") And TimeValue(sj) <= TimeValue("9:30:00") Then
                br(n, 6) = Val(ar(kkc, 6))
                If Val(ar(kkc, 6)) > 5 Then
                    br(n, 10) = 5
                Else
                    br(n, 10) = Val(ar(kkc, 6))
                End If
            End If
        Next kkc
    Next kc
Next k
With Sheets("效果")
    .[a1].CurrentRegion.Offset(2).Borders.LineStyle = 0
    .[a1].CurrentRegion.Offset(2) = Empty
    .[a3].Resize(n, UBound(br, 2)) = br
    .[a3].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub

3190496160

餐费补贴.rar (786.72 KB, 下载次数: 11)

2024-9-8 09:44 上传

点击文件名下载附件

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    arr = Sheet1.UsedRange
    Set d = CreateObject("scripting.dictionary")
    s = Sheet2.[b1]
    ReDim brr(1 To UBound(arr), 1 To 10)
    For i = 2 To UBound(arr)
        If arr(i, 3) = s Then
            h = Split(arr(i, 5))
            If Not d.exists(h(0)) Then
                m = m + 1
                brr(m, 1) = s
                brr(m, 2) = arr(i, 4)
                brr(m, 3) = h(0)
                d(h(0)) = m
            End If
            n = d(h(0))
            Select Case Format(h(1), "hh:mm:ss")
            Case #6:30:00 AM# To #9:00:00 AM#
                brr(n, 6) = arr(i, 6)
                If brr(n, 6) > 5 Then
                    brr(n, 10) = 5
                Else
                    brr(n, 10) = brr(n, 6)
                End If
            Case #11:00:00 AM# To #1:00:00 PM#
                brr(n, 5) = arr(i, 6)
                If brr(n, 5) > 10 Then
                    brr(n, 9) = 10
                Else
                    brr(n, 9) = brr(n, 5)
                End If
            Case #5:00:00 PM# To #7:30:00 PM#
                brr(n, 4) = arr(i, 6)
                If brr(n, 4) > 14 Then
                    brr(n, 8) = 14
                Else
                    brr(n, 8) = brr(n, 4)
                End If
            End Select
            brr(n, 7) = "=sum(rc[-1]:rc[-3])"
        End If
    Next
    brr(n + 1, 9) = "共补贴"
    brr(n + 1, 10) = "=sum(r[-1]c:r3c[-2])"
    Sheet2.UsedRange.Offset(2).ClearContents
    Sheet2.[a3].Resize(n + 1, 10) = brr
    Beep
    Set d = Nothing
End Sub