[已解决]以金额拆分工作表?

新会甜橙

1、原始数据表的L列金额十万元(含十万元)以上数据,拆分到十万元以上工作表,如果R列相同,其中有1条或1条以上条数据的L列是十万元(含十万元)以上，其余金额是十万元以下也拆入十万元以上工作表
2、余下十万元以下的拆入十万元以下工作表

最佳答案

月排行榜 / 总排行榜

liuguansky

2013-2-26 10:36

1. Sub JustTest()
   
2.     Dim D As New Dictionary, Arr, i&, j&, t&
   
3.     Dim ArrRe(2 To 3), K&(2 To 3), Ak$(1 To 10000, 1 To 24)
   
4.     ArrRe(2) = Ak: ArrRe(3) = Ak
   
5.     Arr = Range([a2], [a2].End(4).Offset(0, 23)).Value
   
6.     For i = 1 To UBound(Arr)
   
7.         If Not D.Exists(Arr(i, 16)) Then
   
8.             D.Add Arr(i, 16), 3
   
9.         End If
   
10.         If CCur(Arr(i, 12)) >= 100000 Then
    
11.             D(Arr(i, 16)) = 2
    
12.         End If
    
13.     Next
    
14.     For i = 1 To UBound(Arr)
    
15.         j = D(Arr(i, 16))
    
16.         K(j) = K(j) + 1
    
17.         For t = 1 To 24
    
18.             ArrRe(j)(K(j), t) = Arr(i, t)
    
19.         Next t
    
20.     Next i
    
21.     Sheet2.[a1].Resize(K(2), 24) = ArrRe(2)
    
22.     Sheet3.[a1].Resize(K(3), 24) = ArrRe(3)
    
23. End Sub

复制代码

跳转到最佳答案楼层

fjmxwrs

确实没有明白是什么意思

新会甜橙

fjmxwrs 发表于 2013-2-25 22:06
确实没有明白是什么意思

原始数据表的L列金额为拆分工作表,十万元(含十万元)以上数据,拆分到十万元以上工作表
十万元以下拆入十万元以上工作表,
如果R列相同,其中有1条或1条以上条数据的L列是十万元(含十万元)以上拆分到十万元以上工作表

liuguansky

1. Sub JustTest()
   
2.     Dim D As New Dictionary, Arr, i&, j&, t&
   
3.     Dim ArrRe(2 To 3), K&(2 To 3), Ak$(1 To 10000, 1 To 24)
   
4.     ArrRe(2) = Ak: ArrRe(3) = Ak
   
5.     Arr = Range([a2], [a2].End(4).Offset(0, 23)).Value
   
6.     For i = 1 To UBound(Arr)
   
7.         If Not D.Exists(Arr(i, 16)) Then
   
8.             D.Add Arr(i, 16), 3
   
9.         End If
   
10.         If CCur(Arr(i, 12)) >= 100000 Then
    
11.             D(Arr(i, 16)) = 2
    
12.         End If
    
13.     Next
    
14.     For i = 1 To UBound(Arr)
    
15.         j = D(Arr(i, 16))
    
16.         K(j) = K(j) + 1
    
17.         For t = 1 To 24
    
18.             ArrRe(j)(K(j), t) = Arr(i, t)
    
19.         Next t
    
20.     Next i
    
21.     Sheet2.[a1].Resize(K(2), 24) = ArrRe(2)
    
22.     Sheet3.[a1].Resize(K(3), 24) = ArrRe(3)
    
23. End Sub

复制代码