时间段组的矢量运算,自定义函数的思路~

lee1892

whatyang 发表于 2013-1-23 17:43
还有个问题         再求个“临集”的函数——直接描述特点不容易，我说个实际的例子吧                ...

看不懂～～

yjh_27

另开贴，请移步
http://club.excelhome.net/forum. ... d=975734&page=1

6个自定义函数
排序，只对开始时间排序

1. Function FastSort(a)
   
2. '快速排序法
   
3. M = 1
   
4. For i = LBound(a, 1) To UBound(a, 1) - 1
   
5.     If a(i, 1) <= a(i + 1, 1) Then
   
6.         If i > M Then
   
7.             M = i
   
8.         Else
   
9.             i = M
   
10.         End If
    
11.         GoTo kk:
    
12.     Else
    
13.         For j = 1 To UBound(a, 2)
    
14.             x = a(i, j)
    
15.             a(i, j) = a(i + 1, j)
    
16.             a(i + 1, j) = x
    
17.         Next
    
18.         If i <> 1 Then i = i - 2
    
19.     End If
    
20. kk:
    
21. Next i
    
22. FastSort = a
    
23. End Function

复制代码

yjh_27

2 单时间段的整理合并，交集判断

1. Function hb(a, Optional mode = 1)
   
2.     '合并交集时段
   
3.     Dim brr()
   
4.     ReDim brr(1 To 2, LBound(a, 1) To UBound(a, 1))
   
5.     bi = 1
   
6.     jj = False
   
7.     For i = LBound(a, 1) To UBound(a, 1)
   
8.         If a(i, 1) >= a(i, 2) Or a(i, 1) = "" Or a(i, 2) = "" Then GoTo js '丢弃开始晚于结束
   
9.         If bi = 1 Then
   
10.             brr(1, bi) = a(i, 1)
    
11.             brr(2, bi) = a(i, 2)
    
12.             bi = bi + 1
    
13.         Else
    
14.             If brr(2, bi - 1) >= a(i, 1) Then       '交集
    
15.                 brr(2, bi - 1) = a(i, 2)
    
16.                 jj = True
    
17.             Else
    
18.                 brr(1, bi) = a(i, 1)
    
19.                 brr(2, bi) = a(i, 2)
    
20.                 bi = bi + 1
    
21.             End If
    
22.         End If
    
23. js:
    
24.     Next
    
25.     If mode = 0 Then
    
26.         hb = jj
    
27.     Else
    
28.         ReDim Preserve brr(1 To 2, 1 To bi - 1)
    
29.         hb = Application.Transpose(brr)
    
30.     End If
    
31. End Function

复制代码

yjh_27

3加法

1. Function TimeAdd(arrTime1, arrTime2, Optional mode = 0)
   
2.     arr1 = arrTime1
   
3.     arr2 = arrTime2
   
4.    
   
5.     Dim brr()
   
6.     ReDim brr(LBound(arr1, 1) To UBound(arr1, 1) + UBound(arr2, 1), 1 To 2)
   
7.    
   
8.     For bi = LBound(arr1, 1) To UBound(arr1, 1)
   
9.         brr(bi, 1) = arr1(bi, 1)
   
10.         brr(bi, 2) = arr1(bi, 2)
    
11.     Next
    
12.     For bi = bi To UBound(arr1, 1) + UBound(arr2, 1)
    
13.         brr(bi, 1) = arr2(bi - UBound(arr1, 1), 1)
    
14.         brr(bi, 2) = arr2(bi - UBound(arr1, 1), 2)
    
15.     Next
    
16.    
    
17.     arr = FastSort(brr)
    
18.     TimeAdd = hb(arr)
    
19. 
    
20. End Function

复制代码

yjh_27

4减法

1. Function TimeMinus(arrTime1, arrTime2, Optional mode = 0)
   
2.     Dim kong As Boolean
   
3.    
   
4.     arr = arrTime1
   
5.     arr = FastSort(arr)
   
6.     arr1 = hb(arr)
   
7.     arr = arrTime2
   
8.     arr = FastSort(arr)
   
9.     arr2 = hb(arr)
   
10. 
    
11.     Dim brr()
    
12.     ReDim brr(LBound(arr1, 1) To UBound(arr1, 1) * UBound(arr2, 1), 1 To 2)
    
13.    
    
14.     ii1 = LBound(arr2, 1)
    
15.     For i = LBound(arr1, 1) To UBound(arr1, 1)
    
16.         kong = True
    
17.         For ii = ii1 To UBound(arr2, 1)
    
18.             If arr1(i, 1) >= arr2(ii, 1) And arr1(i, 2) <= arr2(ii, 2) Then kong = False: Exit For '全减
    
19.             If arr1(i, 1) >= arr2(ii, 2) Or arr1(i, 2) <= arr2(ii, 1) Then GoTo js '无交集
    
20.             bi = bi + 1
    
21.             kong = False
    
22.             ii1 = ii
    
23.             If arr1(i, 1) < arr2(ii, 2) Then brr(bi, 1) = arr1(i, 1) Else brr(bi, 1) = arr2(ii, 2)
    
24.             If arr1(i, 2) < arr2(ii, 1) Then brr(bi, 2) = arr1(i, 2) Else brr(bi, 2) = arr2(ii, 1)
    
25.             
    
26.             If arr1(i, 2) > arr2(ii, 2) Then kong = True: arr1(i, 1) = arr2(ii, 2)      '继续
    
27.             
    
28. js:
    
29.         Next
    
30.         If kong Then
    
31.             bi = bi + 1
    
32.             brr(bi, 1) = arr1(i, 1)
    
33.             brr(bi, 2) = arr1(i, 2)
    
34.         End If
    
35.     Next
    
36.    
    
37.    
    
38.     arr = FastSort(brr)
    
39.     TimeMinus = hb(arr)
    
40.    
    
41. End Function
    

复制代码

yjh_27

5 交集

1. Function TimeIntersect(arrTime1, arrTime2, Optional mode = 0)
   
2.     arr = arrTime1
   
3.     arr = FastSort(arr)
   
4.     arr1 = hb(arr)
   
5.     arr = arrTime2
   
6.     arr = FastSort(arr)
   
7.     arr2 = hb(arr)
   
8. 
   
9.     Dim brr()
   
10.     ReDim brr(LBound(arr1, 1) To UBound(arr1, 1) * UBound(arr2, 1), 1 To 2)
    
11.    
    
12.     For i = LBound(arr1, 1) To UBound(arr1, 1)
    
13.         For ii = LBound(arr2, 1) To UBound(arr2, 1)
    
14.             bi = bi + 1
    
15.             If arr1(i, 1) > arr2(ii, 1) Then brr(bi, 1) = arr1(i, 1) Else brr(bi, 1) = arr2(ii, 1)
    
16.             If arr1(i, 2) < arr2(ii, 2) Then brr(bi, 2) = arr1(i, 2) Else brr(bi, 2) = arr2(ii, 2)
    
17.         Next
    
18.     Next
    
19.    
    
20.    
    
21.     arr = FastSort(brr)
    
22.     TimeIntersect = hb(arr)
    
23.       
    
24. End Function

复制代码

yjh_27

6 时间统计

1. Function TimeQuantity(arrTime1, Optional mode = 0)
   
2.     arr = arrTime1
   
3.         
   
4.     arr = FastSort(arr)
   
5.     arr = hb(arr)
   
6.    
   
7.     TimeQuantity = 0
   
8.     If mode = "s" Or mode = "S" Then
   
9.         t = 86400     '24 * 60 * 60
   
10.     ElseIf mode = "m" Or mode = "M" Then
    
11.         t = 1440     '24 * 60
    
12.     ElseIf mode = "h" Or mode = "H" Then
    
13.         t = 24
    
14.     Else
    
15.         t = 1
    
16.     End If
    
17. 
    
18.     a = 0
    
19.     For i = LBound(arr, 1) To UBound(arr, 1)
    
20.         a = a + (arr(i, 2) - arr(i, 1)) * t
    
21.     Next
    
22.    
    
23.     TimeQuantity = a
    
24.    
    
25. End Function

复制代码

香川群子

whatyang 发表于 2013-1-23 17:41
原来1440的状态位是用"1"表示的,我思考了一下,时间段组1用"2",时间段组2用"1",然后把2组时间段对应的状态 ...

看了一下附件，就是要把几个函数合并在一起的意思。


我重新改写了一下代码，搞定了。

不过，并没有按照你的思路去做。
没事好好的为啥简单的方法不用，要搞复杂的呢？ 真是服了你了。

1. Function Flag(arrTime) 'arrTime为 时间段组
   
2.     Dim i%, j%, tms%(1441) '设置数值范围 0-1441 比 1-1440 上下各扩展1位 以便后面的虚拟计算
   
3.     For i = 1 To arrTime.Rows.Count
   
4.         For j = arrTime(i, 1) * 1440 To arrTime(i, 2) * 1440
   
5.             tms(j) = 1
   
6.         Next
   
7.     Next
   
8.     Flag = tms
   
9. End Function
   
10. 
    
11. Function TimeVectorCalculation(arrTime1, arrTime2, mode)    '   并集 A∪B"Merge" 交集 A∩B"Intersect" A减B A-(A∩B)"Substract" 临集"Adjacent"
    
12.     TimeFlag1 = Flag(arrTime1)
    
13.     TimeFlag2 = Flag(arrTime2)
    
14.    
    
15.     Dim i%, UniteFlag%(1 To 1440)
    
16.     Select Case mode
    
17.         Case Is = "Merge" '并集 A∪B
    
18.             For i = 1 To 1440
    
19.                 UniteFlag(i) = TimeFlag1(i) + TimeFlag2(i) '并集用加法
    
20.             Next
    
21.    
    
22.         Case Is = "Intersect" '交集 A∩B
    
23.             For i = 1 To 1440
    
24.                 UniteFlag(i) = TimeFlag1(i) * TimeFlag2(i) '交集用乘法
    
25.                 If UniteFlag(i) = 1 Then If UniteFlag(i - 1) = 0 And TimeFlag1(i + 1) * TimeFlag2(i + 1) = 0 Then UniteFlag(i) = 0
    
26.                 '端点处理：A B反向相交端点要作=0无效处理(同向重叠端点仍=1不用处理)
    
27.             Next
    
28.    
    
29.         Case Is = "Substract"    'A减B A-(A∩B)  但实际获得的原理是A和B叠加后，相交部分被改变，A的剩余部分就是所要求的A减B A-(A∩B)
    
30.             For i = 1 To 1440
    
31.                 UniteFlag(i) = TimeFlag1(i) - TimeFlag2(i) '减集用减法
    
32.                 If TimeFlag1(i) + TimeFlag2(i) = 2 Then If TimeFlag1(i - 1) - TimeFlag2(i - 1) = 1 Or TimeFlag1(i + 1) - TimeFlag2(i + 1) = 1 Then UniteFlag(i) = 1
    
33.                 '端点处理：A B反向延长处相交端点要作=1复原处理(同向重叠端点仍=0不用处理)
    
34.             Next
    
35.                
    
36.         Case Is = "Adjacent"     '临集
    
37.             '待写程序... >_<~
    
38.         
    
39.     End Select
    
40.         
    
41.     ReDim TimeResult(1 To 2, 1 To arrTime1.Rows.Count + arrTime2.Rows.Count)
    
42.     t = 0: k = 0
    
43.     For i = 1 To 1440
    
44.         If UniteFlag(i) > 0 Then
    
45.             If t = 0 Then t = 1: k = k + 1: TimeResult(1, k) = Format(i / 1440, "hh:mm")
    
46.         Else
    
47.             If t = 1 Then t = 0: TimeResult(2, k) = Format((i - 1) / 1440, "hh:mm")
    
48.         End If
    
49.     Next
    
50.     ReDim Preserve TimeResult(1 To 2, 1 To k + 1)
    
51.     TimeVectorCalculation = Application.Transpose(TimeResult)
    
52. End Function

复制代码

香川群子

补上附件。

计算输出过程也做了改变，增加了对复制区域是否有数据存在的检测。

香川群子

关于你说的临集问题，问题能理解，但说到计算，那还要看你的原始数据和结果要求各自是什么。

否则爱莫能助。