自动计算陪餐费求助

chxw68 · 发表于 2024-9-25 14:55

大概写了一个。7楼的问题还是没理解。

chxw68 · 发表于 2024-9-25 16:44

Sub test()
Dim r%, i%, m%
Dim arr, brr, zrr()
Dim d As Object
Dim rqmin As Date
Dim rqmax As Date
Dim rq1 As Date
Dim flg As Boolean
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With Worksheets("统计陪餐费")
rq = .Range("bq1").Value
End With
With Worksheets("就餐人数表")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 6).End(xlUp).Row
arr = .Range("a2:a" & r)
For i = 1 To UBound(arr)
If Format(arr(i, 1), "yyyymm") = Format(rq, "yyyymm") Then
d1(arr(i, 1)) = Empty
End If
Next
n = 2
For Each aa In d1.keys
d1(aa) = n
n = n + 3
If rqmin = #12:00:00 AM# Then
rqmin = aa
Else
If rqmin > aa Then
rqmin = aa
End If
End If
If rqmax = #12:00:00 AM# Then
rqmax = aa
Else
If rqmax < aa Then
rqmax = aa
End If
End If
Next
ls = 1 + d1.Count * 3 + 2
r = .Cells(.Rows.Count, 6).End(xlUp).Row
arr = .Range("f2:i" & r)
End With
For i = 1 To UBound(arr)
xm = Right(arr(i, 2), 2)
Select Case arr(i, 2)
Case "小工友", "大工友", "其它人员"
For rq1 = Application.Max(rqmin, arr(i, 3)) To Application.Min(rqmax, arr(i, 4))
If d1.exists(rq1) Then
n = d1(rq1)
If Not d.exists(xm) Then
Set d(xm) = CreateObject("scripting.dictionary")
End If
If Not d(xm).exists(arr(i, 1)) Then
ReDim brr(1 To ls)
brr(1) = arr(i, 1)
Else
brr = d(xm)(arr(i, 1))
End If
brr(n) = 3
brr(n + 1) = 5
If arr(i, 2) = "大工友" Or arr(i, 2) = "其它人员" Then
brr(n + 2) = 5
End If
d(xm)(arr(i, 1)) = brr
End If
Next
Case "教师"
For rq = Application.Max(rqmin, arr(i, 3)) To Application.Min(rqmax, arr(i, 4))
If d1.exists(rq) Then
d2(arr(i, 1)) = Empty
Exit For
End If
Next
End Select
Next
If d2.Count <> 0 Then
Set d("教师") = CreateObject("scripting.dictionary")
js = d2.keys
riqi = d1.keys
m = 0
For i = 0 To UBound(riqi)
n = d1(riqi(i))
If i <> 0 Then
If riqi(i) <> riqi(i - 1) + 1 Then
m = m + 2
End If
End If
If m + 1 > UBound(riqi) Then
Exit For
End If
For q = 1 To 2
If Not d("教师").exists(js(m + q - 1)) Then
ReDim brr(1 To ls)
brr(1) = js(m + q - 1)
Else
brr = d("教师")(js(m + q - 1))
End If
brr(n) = 3
brr(n + 1) = 5
brr(n + 2) = 5
d("教师")(js(m + q - 1)) = brr
Next
Next
End If
With Worksheets("统计陪餐费")
.UsedRange.Offset(2, 0).Clear
With .Range("a3")
.Value = "陪餐人员"
.Resize(3, 1).Merge
End With
n = 2
For Each aa In d1.keys
With .Cells(3, n)
.NumberFormatLocal = "m月d日"
.Value = aa
.Resize(1, 3).Merge
End With
With .Cells(4, n)
.NumberFormatLocal = "[$-zh-CN]aaaa;@"
.Value = aa
.Resize(1, 3).Merge
End With
.Cells(5, n).Resize(1, 3) = Array("旱", "中", "晚")
n = n + 3
Next
With .Cells(3, n)
.Value = "顿人次"
.Resize(3, 1).Merge
End With
n = n + 1
With .Cells(3, n)
.Value = "金额"
.Resize(3, 1).Merge
End With
With .Range("a3").Resize(3, ls)
.Interior.Color = 10441261
.Font.Color = 16777215
End With
r = 6
For Each aa In Array("工友", "教师", "人员")
If d.exists(aa) Then
m = 0
ReDim crr(1 To d(aa).Count, 1 To ls)
ReDim drr(1 To ls)
drr(1) = IIf(aa <> "人员", aa & "小计", "其它小计")
For Each bb In d(aa).keys
brr = d(aa)(bb)
For j = 2 To ls - 2
If Len(brr(j)) <> 0 Then
brr(ls - 1) = brr(ls - 1) + 1
brr(ls) = brr(ls) + brr(j)
End If
Next
m = m + 1
For j = 1 To UBound(brr)
crr(m, j) = brr(j)
Next
For j = 2 To UBound(brr)
drr(j) = drr(j) + brr(j)
Next
Next
.Cells(r, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
.Cells(r + UBound(crr), 1).Resize(1, UBound(drr)) = drr
r = r + UBound(crr) + 1
End If
Next
With .Range("a3").Resize(r - 3, ls)
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
.Columns(1).Resize(, ls).AutoFit
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2024-9-25 16:44

比较复杂的问题，11楼代码完全是错的。

yangqianming · 发表于 2024-9-25 17:19

chxw68 发表于 2024-9-25 16:44

真是太厉害了！无私奉献的褚老师！让人敬佩！

yangqianming · 发表于 2024-9-25 17:25

chxw68 发表于 2024-9-25 16:44
比较复杂的问题，11楼代码完全是错的。

我刚刚把问题整理您就给修改得差不多了，谢谢！

chxw68 · 发表于 2024-9-25 17:44

修改好了。

xsy我可以很好 · 发表于 2024-9-25 17:52

本帖最后由 xsy我可以很好于 2024-9-25 18:27 编辑

就餐费统计.rar (31.97 KB, 下载次数: 2)

我这个也是正确的哦，只是楼主不愿意变通，看也不看一眼

xsy我可以很好 · 发表于 2024-9-25 17:56

chxw68 发表于 2024-9-25 17:44
修改好了。

他的样表就多了一个周六、一个周日，这有点误导，所以我早上的代码没有破除周末

chxw68 · 发表于 2024-9-25 18:17

xsy我可以很好发表于 2024-9-25 17:56
他的样表就多了一个周六、一个周日，这有点误导，所以我早上的代码没有破除周末

它在原始表里的A列跟后面几列是没有关系的，我11楼的代码也理解错了。

yangqianming · 发表于 2024-9-25 18:59

chxw68 发表于 2024-9-25 18:17
它在原始表里的A列跟后面几列是没有关系的，我11楼的代码也理解错了。

真是感谢！能否在最后加个总计行，把工友，教师，其它人员的数字加总，把小计，总计改成公式（这样如果在有特殊情况手动修改一下数据，结果就自动更改过来了）麻烦了！

		自动登录	找回密码
密码			免费注册

[求助] 自动计算陪餐费求助

评分

评分

评分