中国式过马路

爱疯

1. Sub test()
   
2.     Dim d As Object, A(), B(), C(), x, i&, j&, k%, s%, p%, q%
   
3. 
   
4. 
   
5.     '指定每波人数
   
6.     x = Application.InputBox("凑够多少人,就过马路:", "输入", 10, , , , , 1)
   
7.     If x = 0 Then End
   
8. 
   
9. 
   
10.     '初值
    
11.     With Sheets("sheet1")
    
12.         .Range("C:C").Clear
    
13.         A = .Range("A1:C" & .Range("A65536").End(xlUp).Row).Value
    
14.         A(1, 2) = "序号"
    
15.         A(1, 3) = "第几批"
    
16.     End With
    
17. 
    
18. 
    
19.     '一人一行，建数组B
    
20.     For i = 2 To UBound(A)
    
21.         s = s + A(i, 2)
    
22.     Next i
    
23.     ReDim B(1 To s + 1, 1 To UBound(A, 2))
    
24.     For j = 1 To UBound(B, 2)
    
25.         B(1, j) = A(1, j)
    
26.     Next j
    
27. 
    
28. 
    
29.     '序号和第几批
    
30.     s = 1
    
31.     Set d = CreateObject("scripting.dictionary")
    
32.     For i = 2 To UBound(A)
    
33.         For j = 1 To A(i, 2)
    
34.             s = s + 1
    
35.             B(s, 1) = A(i, 1)
    
36.             d(A(i, 1)) = d(A(i, 1)) + 1: B(s, 2) = d(A(i, 1))
    
37.             B(s, 3) = (s - 2) \ x + 1
    
38.         Next j
    
39.     Next i
    
40.     Set d = Nothing
    
41. 
    
42.     '>>> 仅为测试效果，可注释
    
43.     '样式
    
44.     Columns("e:g").Clear
    
45.     Range("e1").Resize(UBound(B), UBound(B, 2)) = B
    
46.     '填色好查看
    
47.     For i = 2 To UBound(B) Step x
    
48.         Cells(i, "e").Resize(x, UBound(B, 2)).Interior.Color = _
    
49.         RGB(Int(Rnd * 123) + 99, Int(Rnd * 123) + 99, Int(Rnd * 123) + 99)
    
50.     Next i
    
51.     '<<<
    
52. 
    
53.     '把连续的人群作为一个单位
    
54.     s = 1: p = 1
    
55.     ReDim A(1 To UBound(B), 1 To UBound(B, 2))
    
56.     For j = 1 To UBound(A, 2)
    
57.         A(1, j) = B(1, j)
    
58.     Next j
    
59.     For i = 2 To UBound(A) - 1
    
60. 
    
61.         '是否往数组A写入新元素
    
62.         If B(i, 1) <> B(i + 1, 1) And B(i, 2) + 1 <> B(i + 1, 2) Or _
    
63.            B(i, 3) <> B(i + 1, 3) Then
    
64.             q = B(i, 2)   '当前的终点
    
65. 
    
66.             '记录当前的范围
    
67.             s = s + 1
    
68.             A(s, 1) = B(i, 1)
    
69.             A(s, 2) = p & "到" & q
    
70.             A(s, 3) = B(i, 3)
    
71. 
    
72.             p = B(i + 1, 2)   '下一个的起点
    
73.             k = B(i + 1, 2)    '新起点
    
74.         Else
    
75.             k = p    '旧起点
    
76.         End If
    
77. 
    
78.         '倒数第2行时，就记录最后一个范围
    
79.         If i = UBound(B) - 1 Then
    
80.             s = s + 1
    
81.             A(s, 1) = B(i + 1, 1)
    
82.             A(s, 2) = k & "到" & B(i + 1, 2)
    
83.             A(s, 3) = B(i + 1, 3)
    
84.         End If
    
85.     Next i
    
86. 
    
87.     '最终输出
    
88.     Columns("J:L").Clear
    
89.     Range("J1").Resize(s, UBound(A, 2)) = A
    
90. 
    
91. End Sub

复制代码

中国式过马路2.rar (12.47 KB, 下载次数: 24)

2013-4-13 12:02 上传

点击文件名下载附件


可能还有错误吧，自己觉得这类问题有点意思。
只是勉强实现，比预想的，麻烦一些，希望能改好。
谢谢！

wayy

思路可以考虑规划求解

爱疯

wayy 发表于 2013-4-12 22:24
思路可以考虑规划求解

谢谢yy!
我几乎没用过规划求解，都忘光了，可以做出下图类似的结果么？

hwc2ycy

中国式过马路是团结的表现，{:912:}

爱疯

hwc2ycy 发表于 2013-4-12 22:46
中国式过马路是团结的表现，

感觉像一种题型，所以希望学习一下{:021:}

向前冲

呵呵，应该按运筹学的方法以做

爱疯

向前冲 发表于 2013-4-16 10:38
呵呵，应该按运筹学的方法以做

这个。。。。咱没学过
运筹学是什么思路呀

风林火山

过马路都可以这样了？水平真的太高了。

yyyydddd8888

思路奇妙！很好！学习了！