[已解决]关于自动插入行的VBA代码

一休和尚

大师们，附件中的VBA代码实现了自动插入行的要求，按照F列的数字能自动插入下面的行；
现在的缺陷是如果F列的数字减少了，下面插入的行却不能随着F列的数字二自动改变；
我的要求是，在现在的代码基础上，能实现F列数字改变，下面插入的行数也随之改变；
下载后可以运行一下，看一下现在的情况，然后把F列的数字减少，能实现删除行的代码；
比如：F列中是6，下面插入5行，把F列改成8，下面会增加2行，如果把F列改成4，却不会减少成3行，要求实现这个目的；
求大神改一下代码！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-11-2 15:13

1. Sub 插入()
   
2.     Application.ScreenUpdating = False
   
3.     Dim NumA&, NumB&, arr(), arrNum&
   
4.     arrNum = [F65536].End(3).Row
   
5.     arr = Range("f1:f" & arrNum)
   
6.     For i = arrNum To 2 Step -1
   
7.         NumA = Int(arr(i, 1))
   
8.         If NumA > 0 Then
   
9.             r1 = i       '起始行
   
10.             If i = arrNum Then
    
11.                 r2 = [b65536].End(3).Row
    
12.             Else
    
13.                 If arr(i + 1, 1) = "" Then r2 = Cells(i, "f").End(xlDown).Row - 1 Else r2 = r1 '结束行
    
14.             End If
    
15.             NumB = r2 - r1 + 1       '表中实际的总件数
    
16.             If NumB > NumA Then '如果实际总件数大于要改的总件数，删除
    
17.                 Cells(r1 + NumA, 1).Resize(NumB - NumA).EntireRow.Delete
    
18.             ElseIf NumB < NumA Then        '如果实际总件数小于要改的总件数，插入
    
19.                 Cells(r2 + 1, 1).Resize(NumA - NumB).EntireRow.Insert
    
20.                 Cells(r2, 2).Resize(1, 4).Copy Cells(r2 + 1, 2).Resize(NumA - NumB, 4)
    
21.             End If
    
22.         End If
    
23.     Next i
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

一休和尚

恳请高手帮忙啊！

grf1973

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. Application.ScreenUpdating = False
   
3. If Target.Address(0, 0) = "G1" Then
   
4.     Call 恢复
   
5. Dim NumA As Long
   
6.     Dim arr()
   
7.     Dim arrNum As Long
   
8.     Dim codeName As String
   
9.     codeName = "F"
   
10.     arrNum = Sheet3.Cells(Rows.Count, codeName).End(xlUp).Row
    
11.     arr = Sheet3.Range(codeName & "1:" & codeName & arrNum)
    
12.     For i = arrNum To 2 Step -1
    
13.         NumA = Int(arr(i, 1))
    
14.         If NumA > 1 Then
    
15.             For j = 1 To NumA - 1
    
16.                 If Sheet3.Cells(i + j, "F") <> "" Then
    
17.                 Sheet3.Cells(i + j, "F").EntireRow.Insert
    
18.                 End If
    
19.                 With Sheet3
    
20.                 .Range(.Cells(i + j - 1, "B"), .Cells(i + j - 1, "E")).Copy .Range(.Cells(i + j, "B"), .Cells(i + j, "E"))
    
21.                 End With
    
22.             Next j
    
23.         End If
    
24.     Next i
    
25. End If
    
26. Application.ScreenUpdating = True
    
27. End Sub
    
28. 
    
29. Sub 恢复()
    
30.     r = [b65536].End(3).Row
    
31.     Range("f2:f" & r + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
32. End Sub

复制代码

grf1973

运行前加个“恢复”，把新增行删除后重新开始。

一休和尚

你好：
你更改好的代码实现了自动计算的功能，可是这样会把握原来输入进去的一些数据也会一起计算掉的；
我要的是如果改成少的数字，能否从条件的最后一行删除，而不要影响到不删除的行的其它单元格；
帮忙在看一下：

grf1973

原插入行的代码可以优化一下，不用逐行插入

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Application.ScreenUpdating = False
   
3.     If Target.Address(0, 0) <> "G1" Then Exit Sub
   
4.     Dim NumA&, arr(), arrNum&
   
5.     Call 恢复
   
6.     arrNum = [F65536].End(3).Row
   
7.     arr = Range("f1:f" & arrNum)
   
8.     For i = arrNum To 2 Step -1
   
9.         NumA = Int(arr(i, 1))
   
10.         If NumA > 1 Then
    
11.             Cells(i + 1, 1).Resize(NumA - 1).EntireRow.Insert
    
12.             Cells(i, 2).Resize(1, 4).Copy Cells(i + 1, 2).Resize(NumA - 1, 4)
    
13.         End If
    
14.     Next i
    
15.     Application.ScreenUpdating = True
    
16. End Sub
    
17. 
    
18. Sub 恢复()
    
19.     r = [b65536].End(3).Row
    
20.     Range("f2:f" & r + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
21. End Sub
    

复制代码

一休和尚

grf1973 发表于 2015-11-2 13:46
原插入行的代码可以优化一下，不用逐行插入

还是需要逐行插入的，这样才不会把原来输进去的信息替换更新掉；
前面的代码还需要您帮忙在看一下 ；
怎么样才能不把输进去的代码替换掉为好；
感谢您了！

一休和尚

图片中有要求注释

grf1973

1. Sub 插入()
   
2.     Application.ScreenUpdating = False
   
3.     Dim NumA&, NumB&, arr(), arrNum&
   
4.     arrNum = [F65536].End(3).Row
   
5.     arr = Range("f1:f" & arrNum)
   
6.     For i = arrNum To 2 Step -1
   
7.         NumA = Int(arr(i, 1))
   
8.         If NumA > 0 Then
   
9.             r1 = i       '起始行
   
10.             If i = arrNum Then
    
11.                 r2 = [b65536].End(3).Row
    
12.             Else
    
13.                 If arr(i + 1, 1) = "" Then r2 = Cells(i, "f").End(xlDown).Row - 1 Else r2 = r1 '结束行
    
14.             End If
    
15.             NumB = r2 - r1 + 1       '表中实际的总件数
    
16.             If NumB > NumA Then '如果实际总件数大于要改的总件数，删除
    
17.                 Cells(r1 + NumA, 1).Resize(NumB - NumA).EntireRow.Delete
    
18.             ElseIf NumB < NumA Then        '如果实际总件数小于要改的总件数，插入
    
19.                 Cells(r2 + 1, 1).Resize(NumA - NumB).EntireRow.Insert
    
20.                 Cells(r2, 2).Resize(1, 4).Copy Cells(r2 + 1, 2).Resize(NumA - NumB, 4)
    
21.             End If
    
22.         End If
    
23.     Next i
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

grf1973

请看附件。