[已解决]根据某一列的值插入空行？

66327823

求各位大神，俺学校又弄校产登记，要把多于1的资产，分开处理。数据较多，求条VBA代码。

先拜谢各位了

最佳答案

月排行榜 / 总排行榜

芐雨

2014-6-5 11:01

操作可以通过定位空格，ctrl+回车多单元格输入公式来完成。
或者试下面的代码

1. Sub 根据列值插入空行_芐雨()
   
2.     Dim arr, maxRow&, i&, j&, x&, brr(1 To 100000, 1 To 12)
   
3.     maxRow = Cells(Rows.Count, 1).End(3).Row
   
4.     arr = Range("A1:L" & maxRow)  '区域，可自行修改
   
5.     For i = 2 To UBound(arr)
   
6.         x = x + 1
   
7.         For k = 1 To 12
   
8.             brr(x, k) = arr(i, k)
   
9.         Next
   
10.         If arr(i, 8) > 1 Then     '数量大于1
    
11.             For j = 1 To arr(i, 8)
    
12.                 x = x + 1
    
13.                 For k = 1 To 12
    
14.                     brr(x, k) = arr(i, k)
    
15.                 Next
    
16.                 brr(x, 8) = 1
    
17.                 brr(x, 11) = arr(i, 11) / arr(i, 8)
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     Range("A2").Resize(x, 12) = brr    '输出数组
    
22. End Sub
    

复制代码

跳转到最佳答案楼层

66327823

各位大神，给条代码吧，支持一下教育事业吧。

芐雨

这个不用VBA，用操作技巧就可以了，参考下面的动画
数量为1的，你可以筛选出来，或升序放到最顶部。

根据某列值插入N行

xdragon

1. Sub test()
   
2.   Dim arr, re(1 To 10000, 1 To 2), i&, cnt&
   
3.   arr = Range("A2").CurrentRegion.Value
   
4.   For i = 2 To UBound(arr)
   
5.      cnt = cnt + 1
   
6.      re(cnt, 1) = arr(i, 1)
   
7.      re(cnt, 2) = arr(i, 2)
   
8.      If arr(i, 2) = 1 Then arr(i, 2) = 0
   
9.      Do Until arr(i, 2) = 0
   
10.         cnt = cnt + 1
    
11.         re(cnt, 1) = arr(i, 1)
    
12.         arr(i, 2) = arr(i, 2) - 1
    
13.      Loop
    
14.   Next
    
15.   Range("E1:F1") = Array("名称", "数量")
    
16.   Range("E2").Resize(cnt, 2) = re
    
17. End Sub

复制代码

芐雨

代码如下

1. Sub 根据列值插入空行_芐雨()
   
2.     Dim arr, brr(1 To 10000, 1 To 2)
   
3.     arr = Range("A1:B5")    '区域，可自行修改
   
4.     For i = 1 To UBound(arr)
   
5.         x = x + 1
   
6.         brr(x, 1) = arr(i, 1)
   
7.         brr(x, 2) = arr(i, 2)
   
8.         If arr(i, 2) > 1 And i > 1 Then '数量大于1且不是第一行
   
9.             For j = 1 To arr(i, 2)
   
10.                 x = x + 1
    
11.                 brr(x, 1) = arr(i, 1)
    
12.             Next
    
13.         End If
    
14.     Next
    
15.     Range("E1").Resize(x, 2) = brr '输出数组
    
16. End Sub
    

复制代码

66327823

芐雨 发表于 2014-6-4 21:21
代码如下

本来想修改一下您的代码，研究了一节课，没有弄明白数组关系。现附上原文件，麻烦再修改一下吧。

66327823

芐雨 发表于 2014-6-4 20:59
这个不用VBA，用操作技巧就可以了，参考下面的动画
数量为1的，你可以筛选出来，或升序放到最顶部。

插入空行俺看明白了，能不能把首行的数据复制的插入的空行中。

芐雨

操作可以通过定位空格，ctrl+回车多单元格输入公式来完成。
或者试下面的代码

1. Sub 根据列值插入空行_芐雨()
   
2.     Dim arr, maxRow&, i&, j&, x&, brr(1 To 100000, 1 To 12)
   
3.     maxRow = Cells(Rows.Count, 1).End(3).Row
   
4.     arr = Range("A1:L" & maxRow)  '区域，可自行修改
   
5.     For i = 2 To UBound(arr)
   
6.         x = x + 1
   
7.         For k = 1 To 12
   
8.             brr(x, k) = arr(i, k)
   
9.         Next
   
10.         If arr(i, 8) > 1 Then     '数量大于1
    
11.             For j = 1 To arr(i, 8)
    
12.                 x = x + 1
    
13.                 For k = 1 To 12
    
14.                     brr(x, k) = arr(i, k)
    
15.                 Next
    
16.                 brr(x, 8) = 1
    
17.                 brr(x, 11) = arr(i, 11) / arr(i, 8)
    
18.             Next
    
19.         End If
    
20.     Next
    
21.     Range("A2").Resize(x, 12) = brr    '输出数组
    
22. End Sub
    

复制代码