奖励计算

byevenic

根据奖励办法用代码实现奖励统计表

要求见统计表里

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.1.18
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("奖励办法")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 5)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 1) & "|" & arr(i, 2) & "～" & arr(i, 3)
    
11.         d(s) = arr(i, 4)
    
12.     Next
    
13.     With Sheets("奖励情况统计")
    
14.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
15.         arr = .Range("a1:av" & r)
    
16.         For i = 2 To UBound(arr)
    
17.             For j = 3 To UBound(arr, 2) Step 3
    
18.                 s = arr(i, 1) & "|" & Replace(Trim(arr(1, j)), "名人数", "")
    
19.                 If d.Exists(s) Then
    
20.                     If arr(i, j) <> Empty Then
    
21.                         arr(i, j + 1) = d(s)
    
22.                         arr(i, j + 2) = arr(i, j) * arr(i, j + 1)
    
23.                     Else
    
24.                         arr(i, j + 1) = 0
    
25.                         arr(i, j + 2) = 0
    
26.                     End If
    
27.                 End If
    
28.             Next
    
29.         Next
    
30.         .Range("a1:av" & r) = arr
    
31.         ActiveWindow.DisplayZeros = False
    
32.     End With
    
33.     Set d = Nothing
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "OK！"
    
36. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

byevenic

ykcbf1100 发表于 2024-1-18 15:29
附件供参考。。。

非常感谢您

yynrzwh

奖励统计.rar (22.6 KB, 下载次数: 3)

2024-1-18 16:20 上传

点击文件名下载附件

byevenic

yynrzwh 发表于 2024-1-18 16:20

非常感谢你的帮助