[已解决]Excel VBA求助

417051286

大家好， VBA菜鸟一枚， 现在遇到一个棘手难题，我现在在给医院做一个模型，模型的基本组成是清洗-包装-消毒-配送，然后对每个步骤如清洗都有每天的数据，包括清洗数量以及时间，模型与原始数据是在不同的sheet中，现在我想输入任意一段时间，比如6月8号到11号或7月2号到15号（这个用户自主决定），希望模型能够根据原始数据的对应日期可以自动生成（数量，时间），请问通过VBA如何能够办到，多谢大家了

最佳答案

月排行榜 / 总排行榜

grf1973

2014-6-3 14:36

最好调整成一致的。当然也可以智能判断，但比较麻烦。附件表3已调成和表2一样的表式。

1. Sub 统计()
   
2.     Set d1 = CreateObject("scripting.dictionary")
   
3.     Set d2 = CreateObject("scripting.dictionary")
   
4.     sd = [c1]: ed = [c2] '开始日期、结束日期
   
5.     For Each sh In Worksheets
   
6.         If sh.Index > 1 Then
   
7.             arr = sh.[a1].CurrentRegion
   
8.             For i = 2 To UBound(arr)
   
9.                 If arr(i, 2) >= sd And arr(i, 2) <= ed Then
   
10.                     xkey = arr(i, 5)
    
11.                     d1(xkey) = d1(xkey) + arr(i, 1)   '数量累加
    
12.                     d2(xkey) = d2(xkey) + arr(i, 4)   '时间累加
    
13.                 End If
    
14.             Next
    
15.         End If
    
16.     Next
    
17.     arr = [a5:d10]: ra = UBound(arr)
    
18.     xday = ed - sd + 1
    
19.     For i = 2 To ra - 1
    
20.         xkey = arr(i, 1)
    
21.         arr(i, 2) = d1(xkey) / xday
    
22.         arr(i, 3) = d2(xkey) / xday
    
23.         arr(i, 4) = arr(i, 2) * 7
    
24.         s1 = s1 + arr(i, 2)
    
25.         s2 = s2 + arr(i, 3)
    
26.     Next
    
27.     arr(ra, 2) = s1: arr(ra, 3) = s2: arr(ra, 4) = s1 * 7
    
28.     [a5:d10] = arr
    
29. End Sub
    
30. 
    
31. Sub 清除数据()
    
32.     [b6:d10].ClearContents
    
33. End Sub

复制代码

跳转到最佳答案楼层

su45

看了下附件，“任务分类”在各表中的位置不一样，确定是这样么？

417051286

su45 发表于 2014-6-3 12:37
看了下附件，“任务分类”在各表中的位置不一样，确定是这样么？

这个都是可以调整的 有影响么

grf1973

最好调整成一致的。当然也可以智能判断，但比较麻烦。附件表3已调成和表2一样的表式。

1. Sub 统计()
   
2.     Set d1 = CreateObject("scripting.dictionary")
   
3.     Set d2 = CreateObject("scripting.dictionary")
   
4.     sd = [c1]: ed = [c2] '开始日期、结束日期
   
5.     For Each sh In Worksheets
   
6.         If sh.Index > 1 Then
   
7.             arr = sh.[a1].CurrentRegion
   
8.             For i = 2 To UBound(arr)
   
9.                 If arr(i, 2) >= sd And arr(i, 2) <= ed Then
   
10.                     xkey = arr(i, 5)
    
11.                     d1(xkey) = d1(xkey) + arr(i, 1)   '数量累加
    
12.                     d2(xkey) = d2(xkey) + arr(i, 4)   '时间累加
    
13.                 End If
    
14.             Next
    
15.         End If
    
16.     Next
    
17.     arr = [a5:d10]: ra = UBound(arr)
    
18.     xday = ed - sd + 1
    
19.     For i = 2 To ra - 1
    
20.         xkey = arr(i, 1)
    
21.         arr(i, 2) = d1(xkey) / xday
    
22.         arr(i, 3) = d2(xkey) / xday
    
23.         arr(i, 4) = arr(i, 2) * 7
    
24.         s1 = s1 + arr(i, 2)
    
25.         s2 = s2 + arr(i, 3)
    
26.     Next
    
27.     arr(ra, 2) = s1: arr(ra, 3) = s2: arr(ra, 4) = s1 * 7
    
28.     [a5:d10] = arr
    
29. End Sub
    
30. 
    
31. Sub 清除数据()
    
32.     [b6:d10].ClearContents
    
33. End Sub

复制代码

su45

咱又是动作慢了！


模型.zip (33.83 KB, 下载次数: 2)

2014-6-3 15:16 上传

点击文件名下载附件

417051286

谢谢各位 问题已解决 多谢