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

642070295

请问各位热心高手，用什么函数公式或VBA等方法，能一次性的完成所有日期的缩减整理统计？谢谢各位高手大侠帮个忙！！！（上传有附件）

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2013-7-1 13:41

附件请测试
注：测试按钮在TEST工作表内，稍微加了一些测试数据。

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

复制代码

跳转到最佳答案楼层

402031036

？什么意思这？我被绕的非常晕

那么的帅

402031036 发表于 2013-6-29 16:00
？什么意思这？我被绕的非常晕

多列举几个日期。
最好把原始表发上来，并说明结果显示在哪里？

642070295

就是对原表格中B6到B12这列数进行首、尾同时缩减数值呀！

642070295

我重新上传附件吧？！

642070295

对不起对不起！我上传到原先的了，非常抱歉！非常抱歉！我再上传附件，可能看得清楚点，谢谢老师帮帮忙解决一下这个难题！ 求缩减统计方法.rar (9.95 KB, 下载次数: 7)

2013-6-29 16:35 上传

点击文件名下载附件

1032446692

642070295 发表于 2013-6-29 16:35
对不起对不起！我上传到原先的了，非常抱歉！非常抱歉！我再上传附件，可能看得清楚点，谢谢老师帮帮忙解决 ...

你这个不是一样的吗

642070295

这是个按方向减法的统计，是不是用“向量减法”，并编辑VBA模块可以解决？我的附件应该表达清楚了吧？有哪位高手帮解决一下呀！非常感谢！

大灰狼1976

附件请测试
注：测试按钮在TEST工作表内，稍微加了一些测试数据。

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

复制代码

642070295

非常正确！太高兴了，这就是我需要的统计效果，非常感谢9楼“大灰狼1976”高手，对我附件中的表达理解得很到位！真是太感谢了！！！只是我怎样把这一页代码放到我的统计表中？并且怎样操作实现统计？我真是笨死了，还望老师具体指点一下，谢谢老师！很感谢！！！