[已解决]大神请帮帮忙~在线等~数值拆分到多行

grf1973

1. Sub tt()
   
2.     Randomize
   
3.     arr = Range("h1:i" & [h65536].End(3).Row)
   
4.     ReDim brr(1 To UBound(arr))      '记录每组需填的空格位置
   
5.     s = 2: x = arr(s, 1) - arr(s, 2)   '起始行
   
6.     n = IIf(arr(s, 2) > 0, 0, 1)       '每组的空格数
   
7.     If n = 1 Then brr(1) = s
   
8.     For i = 3 To UBound(arr)  '往下
   
9.         If Len(arr(i, 1)) = 0 Then       '表示在本组内
   
10.             If arr(i, 2) = 0 Then     '右列无值，记录位置
    
11.                 n = n + 1
    
12.                 brr(n) = i
    
13.             Else         '右列有值，总额减之
    
14.                 x = x - arr(i, 2)
    
15.             End If
    
16.         Else       '表示本组结束，进入下一组
    
17.             xx = x  '当前余额（在随机数或最后一数出现极小数时需重新调用）
    
18.             If n = 1 Then      '本组只有一个空，直接填之
    
19.                 arr(brr(n), 2) = x
    
20.             Else
    
21. 100:                x = xx     '恢复当前余额
    
22.                 For k = 1 To n - 1 '超过一个空，前n-1个空随机数
    
23.                     y = Round(x * Rnd, 2)
    
24.                         If y < 0.001 Then k = 1: GoTo 100
    
25.                      x = x - y
    
26.                      arr(brr(k), 2) = y
    
27.                 Next
    
28.                 If x < 0.001 Then k = 1: GoTo 100
    
29.                 arr(brr(k), 2) = x
    
30.             End If
    
31.             s = i: x = arr(s, 1) - arr(s, 2)   '下一组起始行，并初始化brr及x
    
32.             n = IIf(arr(s, 2) > 0, 0, 1)
    
33.             If n = 1 Then brr(1) = s
    
34.         End If
    
35.     Next
    
36.     [i1].Resize(UBound(arr)) = Application.Index(arr, , 2)
    
37. End Sub

复制代码

grf1973

请看附件。

393793980

grf1973 发表于 2016-6-3 13:43
请看附件。

非常感谢大神，近期一直加班，忙的上厕所时间都是跑步去的。{:021:}没想到大神已经做好了~大神请收下我的膝盖~{:091:}thank you very much~~~~