[已解决]怎样对一列数进行上下缩减整理统计

大灰狼1976

你上传实际的统计表吧，我看看，直接做好

642070295

谢谢老师，我把统计表上传吧，日期很多、并且有些日期的数据较长的哦，辛苦老师了！我想再加一点点要求就是：每当“从上往下减量和从下往上减量”数值更新时，能相应的自动进行上下缩减。非常感谢老师百忙中操出时间帮帮俺解决困难，谢谢！！！

642070295

“大灰狼1976”大师，你的“最佳答案”VBA模块在TEST测试表进行测试很棒！但将这VBA模块粘贴到实际统计表代码编辑器里保存后执行，实际统计表却没有任何效果反应，怎么办？我把实际统计表上传，麻烦大师再帮看看吧！谢谢啦！祝好人一生平安！！！ 缩减统计原表.rar (216.52 KB, 下载次数: 6)

2013-7-5 10:03 上传

点击文件名下载附件

大灰狼1976

不好意思，一时忘记了，今天才看到，能不能上传2003格式的，家里的EXCEL版本低

642070295

对不起呀，前两天考驾照去了，今天打开电脑才看到你的贴。怎么转成excel2003格式？

642070295

哦，已由2010版格式转成2003版了，但数据只到IV列（原表格数据到ADF列的），少了很多数据呀？！怎么办呢？大灰狼大师帮想想办法吧！谢谢！ 缩减统计原表(2003版）.rar (38.28 KB, 下载次数: 1)

2013-7-11 16:12 上传

点击文件名下载附件

642070295

您好！“大灰狼1976”老师，首先祝您工作顺利，心想事成！非常感谢您热心的回帖和成功的帮助！请问大灰狼1976老师能否留个QQ号或电子邮箱地址？方便的时候我想请老师您多多指教，很想向老师多学一点！我的QQ号642070295，邮箱642070295@qq.com.谢谢老师！

642070295

大灰狼1976老师，您能否帮忙把您回帖（是EXCEL2003版的）最佳答案修改为EXCEL2010版VBA代码给俺？并且每次运行程序时，不要因某个日期的数据已缩减到了小于或等于0时而中断了执行其他日期数据的缩减，应该执行过一遍缩减后再提示哪些日期的数据已经缩减到了小于或等于0。麻烦老师帮忙顺便一起修改一下可以吗？谢谢！

大灰狼1976

附件请测试，如果是2010版，请将第4行代码的[iv1]的IV换成相应的最大列号
如果行数超过65536，还需要把代码内有65536的部分换成2010版的最大行数

1. Private Sub CommandButton1_Click()
   
2. Dim arr, i&, j%, d As Object
   
3. Set d = CreateObject("scripting.dictionary")
   
4. For j = 1 To [iv1].End(1).Column Step 2
   
5.   arr = Range(Cells(2, j), Cells(Cells(65536, j).End(3).Row, j + 1))
   
6.   Range(Cells(5, j), Cells(Cells(65536, j).End(3).Row + 1, j + 1)).ClearContents
   
7.   For i = 4 To UBound(arr)
   
8.     If arr(i, 1) = "" Then Exit For
   
9.     If arr(2, 1) - arr(i, 1) >= 0 Then
   
10.       arr(2, 1) = arr(2, 1) - arr(i, 1)
    
11.       arr(i, 1) = ""
    
12.     Else
    
13.       arr(i, 1) = arr(i, 1) - arr(2, 1)
    
14.       Exit For
    
15.     End If
    
16.   Next i
    
17.   For i = UBound(arr) To 4 Step -1
    
18.     If arr(i, 1) = "" Then Exit For
    
19.     If arr(2, 2) - arr(i, 1) >= 0 Then
    
20.       arr(2, 2) = arr(2, 2) - arr(i, 1)
    
21.       arr(i, 1) = ""
    
22.     Else
    
23.       arr(i, 1) = arr(i, 1) - arr(2, 2)
    
24.       Exit For
    
25.     End If
    
26.   Next i
    
27.   For i = 4 To UBound(arr)
    
28.     If arr(i, 1) <> "" Then d(arr(i, 2)) = arr(i, 1)
    
29.   Next i
    
30.   If d.Count >= 1 Then
    
31.     Cells(5, j).Resize(d.Count, 1) = Application.Transpose(d.items)
    
32.     Cells(5, j + 1).Resize(d.Count, 1) = Application.Transpose(d.keys)
    
33.     d.RemoveAll
    
34.     Erase arr
    
35.   End If
    
36. Next j
    
37. End Sub

复制代码

642070295

非常感谢“大灰狼1976”老师，请授学生一拜！老师您的编程对该缩减统计解决得非常漂亮！愿在今后的继续学习中能得到老师您的多多指教！！！顺祝老师生活安康、幸福！