请帮忙写一个VBA，任意单元格下方插入一行并延续公式

准提部林

F6沒有公式, 上方不能再插入行//

SelectionChange 插入行// 可能就無法做刪除行//
還是建議按鈕...重新刷一次公式...刷好刷滿

gbgbxgb

准提部林 发表于 2023-2-5 16:54
F6沒有公式, 上方不能再插入行//

SelectionChange 插入行// 可能就無法做刪除行//

从楼主的附件内容看，其实际操作场景是不做行删除的。
即便删除了行，导致公式出现了#Ref!错误，手动拖曳公式复制下即可。
有兴趣的话，看看我的代码（参照你的代码思路作了大的变动）：

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Dim theRow&, theEndRow&, theAns&
   
3.     '
   
4.     With Target
   
5.         If .EntireRow.Address = .Address Then
   
6.             theRow = .Row
   
7.             If theRow > 6 Then
   
8.                 With .Parent
   
9.                     If WorksheetFunction.CountA(.Range(.Cells(theRow, 4), .Cells(theRow, 5))) = 0 Then
   
10.                         theAns = MsgBox("插入行吗？", vbYesNo + vbExclamation, "确认")
    
11.                         If theAns = vbYes Then
    
12.                             .Cells(theRow, 1).Resize(Target.Rows.Count).EntireRow.Insert Shift:=xlDown
    
13.                             theEndRow = .Cells(.Rows.Count, 6).End(xlUp).Row
    
14.                             If theEndRow > theRow + Target.Rows.Count - 1 Then
    
15.                                 .Range(.Cells(7, 6), .Cells(theEndRow, 6)).FormulaR1C1 = "=IF(RC[-2]+RC[-1]=0,"""",R[-1]C+RC[-2]-RC[-1])"
    
16.                             Else
    
17.                                 .Range(.Cells(7, 6), .Cells(theRow + Target.Rows.Count - 1, 6)).FormulaR1C1 = "=IF(RC[-2]+RC[-1]=0,"""",R[-1]C+RC[-2]-RC[-1])"
    
18.                             End If
    
19.                             Application.EnableEvents = False
    
20.                             .Cells(theRow, 1).Select
    
21.                             Application.EnableEvents = True
    
22.                         End If
    
23.                     End If
    
24.                 End With
    
25.             End If
    
26.         End If
    
27.     End With
    
28. End Sub

复制代码