[已解决]请帮忙解决下这个问题，谢谢，具体见附件

jiangslly

请帮忙解决下这个问题，谢谢，具体见附件，谢谢了

最佳答案

月排行榜 / 总排行榜

蓝桥玄霜

2012-3-4 20:47

1. Sub yy()
   
2. Dim Arr, i&, d, k, t, n&, x, r1
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. Arr = Sheet2.[a1].CurrentRegion
   
7. For i = 2 To UBound(Arr)
   
8.     Select Case Day(Arr(i, 1))
   
9.         Case 1 To 7
   
10.             n = 1
    
11.         Case 8 To 14
    
12.             n = 2
    
13.         Case 15 To 21
    
14.             n = 3
    
15.         Case 22 To 28
    
16.             n = 4
    
17.         Case Else
    
18.             n = 5
    
19.     End Select
    
20.     d(n & "|" & Arr(i, 2)) = d(n & "|" & Arr(i, 2)) + Arr(i, 3)
    
21. Next
    
22. k = d.keys
    
23. t = d.items
    
24. For i = 0 To UBound(k)
    
25.     x = Split(k(i), "|")
    
26.     Set r1 = Rows(1).Find(x(1), , , 1)
    
27.     Cells(x(0) + 1, r1.Column + 1) = t(i)
    
28.     If t(i) > Cells(x(0) + 1, r1.Column + 1).Offset(0, 1).Value Then Cells(x(0) + 1, r1.Column + 1).Interior.ColorIndex = 6
    
29. Next
    
30. Application.ScreenUpdating = True
    
31. End Sub
    

复制代码

跳转到最佳答案楼层

那么的帅

把预算数据和实际数据补充完成，以便于测试。

jiangslly

那么的帅 发表于 2012-3-3 11:38
把预算数据和实际数据补充完成，以便于测试。

已经补充完整了，谢谢！

jiangslly

那么的帅 发表于 2012-3-3 11:38
把预算数据和实际数据补充完成，以便于测试。

请问能提供一些思路吗？谢谢了

无聊的疯子

jiangslly 发表于 2012-3-4 11:59
请问能提供一些思路吗？谢谢了

使用 Change 事件 根据对应的周和部门进行汇总，，

当输入的金额汇总后大于 预算金额，则提示不能输入，并提示可输入的最大值

思路不就是和你想的一样嘛？

jiangslly

无聊的疯子 发表于 2012-3-4 12:08
使用 Change 事件 根据对应的周和部门进行汇总，，

当输入的金额汇总后大于 预算金额，则提示不能输入 ...

那代码怎么编写啊？我主要是代码不知道咋办

蓝桥玄霜

1. Sub yy()
   
2. Dim Arr, i&, d, k, t, n&, x, r1
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. Arr = Sheet2.[a1].CurrentRegion
   
7. For i = 2 To UBound(Arr)
   
8.     Select Case Day(Arr(i, 1))
   
9.         Case 1 To 7
   
10.             n = 1
    
11.         Case 8 To 14
    
12.             n = 2
    
13.         Case 15 To 21
    
14.             n = 3
    
15.         Case 22 To 28
    
16.             n = 4
    
17.         Case Else
    
18.             n = 5
    
19.     End Select
    
20.     d(n & "|" & Arr(i, 2)) = d(n & "|" & Arr(i, 2)) + Arr(i, 3)
    
21. Next
    
22. k = d.keys
    
23. t = d.items
    
24. For i = 0 To UBound(k)
    
25.     x = Split(k(i), "|")
    
26.     Set r1 = Rows(1).Find(x(1), , , 1)
    
27.     Cells(x(0) + 1, r1.Column + 1) = t(i)
    
28.     If t(i) > Cells(x(0) + 1, r1.Column + 1).Offset(0, 1).Value Then Cells(x(0) + 1, r1.Column + 1).Interior.ColorIndex = 6
    
29. Next
    
30. Application.ScreenUpdating = True
    
31. End Sub
    

复制代码

蓝桥玄霜

请见附件。

jiangslly

蓝桥玄霜 发表于 2012-3-4 20:47
请见附件。

你好，非常感谢你，大部分完成了，就还有一点点，可能是我没说清楚的原因，就是当明细表中的每一周的金额超过预算金额的时候，就在预算表中报警，并将最后那次超过预算的金额删除
举个例子
假如部门1 从1号到7号第一周的实际费用如下
1.1       200
1.2        100
1.3        300
假如部门1月第一周的预算费用为350
那么当在1.3号输入300的时候，就报警超过预算了，并将300删除，现在就差这个功能，我在想是不是要加个change时间才能解决，请指教

蓝桥玄霜

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Count > 1 Or Target = "" Then Exit Sub
   
3. If Target.Column <> 3 Or Target.Row < 2 Then Exit Sub
   
4. Dim m&, n%, Arr, i&, d, k, t, x, r1, bm$
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. m = Target.Row: bm = Target.Offset(0, -1).Value
   
7. Arr = Range("a2:c" & m)
   
8. For i = 1 To UBound(Arr)
   
9.     Select Case Day(Arr(i, 1))
   
10.         Case 1 To 7
    
11.             n = 1
    
12.         Case 8 To 14
    
13.             n = 2
    
14.         Case 15 To 21
    
15.             n = 3
    
16.         Case 22 To 28
    
17.             n = 4
    
18.         Case Else
    
19.             n = 5
    
20.     End Select
    
21.     If Arr(i, 3) <> "" Then
    
22.     d(n & "|" & Arr(i, 2)) = d(n & "|" & Arr(i, 2)) + Arr(i, 3)
    
23.     End If
    
24. Next
    
25. k = d.keys
    
26. t = d.items
    
27. For i = 0 To UBound(k)
    
28.     x = Split(k(i), "|")
    
29.     If x(1) = bm Then
    
30.     Set r1 = Sheet1.Rows(1).Find(x(1), , , 1)
    
31.     If Sheet1.Cells(x(0) + 1, r1.Column + 2) < t(i) Then
    
32.         MsgBox bm & " 已经超过第" & x(0) & " 周预算，警告"
    
33.         Target.Value = "": Exit For
    
34.     End If
    
35.     End If
    
36. Next
    
37. End Sub
    

复制代码