数据拆分后自动分行

zhuangtianwen

各位高手，现在碰到一个难题。在这里像各位高手求助，谢谢。
具体要求是这样的：需要依据付款金额把某一行拆分了：如果付款金额大于1万，以1万为基数自动分解成若干行，原行删除，如果付款金额小于1万，则原行保留不动。
具体需求见附件（内含原表和需求两个sheet的） 1.31.rar (17.36 KB, 下载次数: 16)

2013-3-2 10:38 上传

点击文件名下载附件

谢谢各位了。

wajour

你好，你的需求已经做好，其他不解释，只要你原表格式不变，均可秒拆

wajour

附上代码

1. Sub 矩形1_Click()
   
2.     Dim arr()
   
3.     Dim Arr2()
   
4.     Dim Count As Integer
   
5.     Dim Count2 As Integer
   
6.     Count2 = 1
   
7.     arr = Range("A2:G" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
8.     For i = 1 To UBound(arr)
   
9.         Count = Count + Application.WorksheetFunction.RoundUp(arr(i, 4) / 10000, 0)
   
10.     Next
    
11.     ReDim Arr2(1 To Count, 1 To 7)
    
12.     For i = 1 To UBound(arr)
    
13.     If arr(i, 4) <= 10000 Then
    
14.         For j = 1 To 7
    
15.         Arr2(Count2, j) = arr(i, j)
    
16.         Next
    
17.          Count2 = Count2 + 1
    
18.     Else
    
19.         余数 = arr(i, 4)
    
20.         For k = 1 To Application.WorksheetFunction.RoundUp(arr(i, 4) / 10000, 0)
    
21.         For j = 1 To 7
    
22.         Arr2(Count2, j) = arr(i, j)
    
23.         Next
    
24.         Arr2(Count2, 1) = arr(i, 1) & "_" & k
    
25.         Arr2(Count2, 4) = Application.WorksheetFunction.Min(余数, 10000)
    
26.         余数 = 余数 - Application.WorksheetFunction.Min(余数, 10000)
    
27.         Count2 = Count2 + 1
    
28.         Next
    
29.     End If
    
30.     Next
    
31.     With Sheets.Add
    
32.     On Error Resume Next
    
33.     Application.DisplayAlerts = False
    
34.     Sheets("TEMP").Delete
    
35.     Application.DisplayAlerts = True
    
36.     .Name = "TEMP"
    
37.     .Range("A1").Resize(UBound(Arr2), 7) = Arr2
    
38.     .Columns.AutoFit
    
39.     End With
    
40. End Sub

复制代码

zhuangtianwen

wajour 发表于 2013-3-2 15:22
附上代码

谢谢啦。。我试试。。要是格式变了呢。。比如列增加了。。