VBA插入行即复制上行格式和所有公式

打开话匣子

各位大师，请帮忙写一个代码。要求是：        1.插入一行至N行，自动复制(触发事件）上行的格式和所有公式（黄色部分），不要复制内容。
        2.循环区域从第9行至K列最后有数据的倒数第2行。意思是从第9行开始至27行（目前是27行），在中间任意位置插入行，自动复制上行格式和所有公式，如已插入一行，区域即扩大到第28行，如在27行时删除了一行，区域是9－26行。劳烦大师了。谢谢！ 复制上行公式.zip (38.13 KB, 下载次数: 22)

2021-6-28 15:07 上传

点击文件名下载附件

hzruziniu

复制上行公式.rar (55.1 KB, 下载次数: 84)

2021-6-29 09:13 上传

点击文件名下载附件

hzruziniu

1. Private Sub CommandButton1_Click()
   
2.     Dim k As Range, i%
   
3.     Application.EnableEvents = True
   
4.     Application.EnableEvents = False
   
5.     Set k = Application.InputBox("请点选要插入行所在上一行的任何单元格——", "Selection：", Type:=8)  '选择在下方插入行的单元格
   
6.     On Error Resume Next
   
7.     If Not k Is Nothing Then
   
8.         i = k.Row                                                                         '选中的行号
   
9.         n = InputBox("请你输入在选中的单元格下方插入的行数，默认为1行！", , 1)            '插入行数
   
10.         If StrPtr(n) = 0 Then Exit Sub
    
11.         Cells(i + 1, 1).Resize(n, 1).EntireRow.Insert                                     '在选中行i的下方插入n行
    
12.         Range(Cells(i, 1), Cells(i + n, 33)).FillDown                                     '向下填充公式
    
13.         Cells(i + 1, 1).Resize(n, 33).SpecialCells(xlCellTypeConstants, 1) = ""           '清除公式以外的常量
    
14.        ' Cells(i + 1, 1).Resize(n, 33).SpecialCells(2) = ""
    
15.     End If
    
16.     Application.EnableEvents = True
    
17. End Sub

复制代码

打开话匣子

hzruziniu大师，能把“请点选要插入行所在上一行的任何单元格——”和"请你输入在选中的单元格下方插入的行数，默认为1行！"提示去掉，直接在活动单元格的下方插入行，点一次快捷键插入3行，可以点N次。单元格有数据不复制。谢谢！

打开话匣子

hzruziniu 发表于 2021-6-29 09:13

hzruziniu大师，能把两个提示去掉，然后直接在活动单元格下方插入行，点击按钮一次插入3行，可点击N次。谢谢！

打开话匣子

hzruziniu 发表于 2021-6-29 09:13

只复制格式和公式，不要复制数据

flyfairy

来学习一下

huangyanqiang

打开话匣子 发表于 2021-6-29 09:52
hzruziniu大师，能把两个提示去掉，然后直接在活动单元格下方插入行，点击按钮一次插入3行，可点击N次。 ...

留言关注，这样效率更高

hzruziniu

打开话匣子 发表于 2021-6-29 09:52
hzruziniu大师，能把两个提示去掉，然后直接在活动单元格下方插入行，点击按钮一次插入3行，可点击N次。 ...

1. Private Sub CommandButton1_Click()
   
2.     Dim k As Range, i%
   
3.     Application.EnableEvents = False
   
4.     On Error Resume Next
   
5.     i = ActiveCell.Row                                                                         '选中的行号
   
6.     Cells(i + 1, 1).Resize(3, 1).EntireRow.Insert                                     '在选中行i的下方插入n行
   
7.     Range(Cells(i, 1), Cells(i + 3, 33)).FillDown                                     '向下填充公式
   
8.     Cells(i + 1, 1).Resize(3, 33).SpecialCells(xlCellTypeConstants, 1) = ""           '清除公式以外的常量
   
9.        ' Cells(i + 1, 1).Resize(n, 33).SpecialCells(2) = ""
   
10.     Application.EnableEvents = True
    
11. End Sub

复制代码

打开话匣子

hzruziniu 发表于 2021-6-30 01:49

hzruziniu大师，您写的代码完美。谢谢！