首先直接回答你的核心疑问：你写的Dim R As Range: Set R = ActiveCell.Address是错误的，根本达不到保存初始ActiveCell地址的目的——因为ActiveCell.Address返回的是一个字符串（比如$A$1），而R是Range类型的对象，这样赋值会直接报错。正确的写法有两种：

• 如果要保存初始选中的单元格对象（推荐）：

  Dim originalCell As Range
  Set originalCell = ActiveCell ' 保存当前活动单元格的引用，不会随后续选中变化而改变
  

• 如果只需要保存地址字符串：

  Dim originalAddr As String
  originalAddr = ActiveCell.Address ' 保存地址字符串，后续可以用Range(originalAddr)找回位置
  

为什么ActiveCell会导致间歇性崩溃？ #

你提到的间歇性崩溃，本质是因为ActiveCell和Selection是依赖Excel UI状态的对象——代码运行过程中，任何可能改变UI选中状态的操作（比如意外触发的工作表事件、Excel后台的自动操作，甚至代码里的Select/Activate）都可能让这些对象的引用变得不稳定，进而导致Excel进程崩溃。这种问题因为依赖环境状态，所以会间歇性出现，难以复现和排查。

如何规避：用固定Range替代ActiveCell/Selection #

你的需求是在用户当前选中位置插入行，完全不需要依赖ActiveCell或Selection——只需要先把用户初始选中的位置保存为一个固定的Range对象，之后所有操作都基于这个对象来定位，彻底摆脱对UI状态的依赖。

重构后的代码示例 #

下面是对你的InsertArea代码的重构版本，移除了所有ActiveCell/Selection的使用，改用预先保存的originalCell来定位操作：

Sub InsertArea()
    ' Dimension variables
    Dim SR As String
    Dim Rng2 As Range
    Dim i As Integer, j As Integer, PB1 As Integer
    Dim Crit() As String
    Dim w As Worksheet
    Dim originalCell As Range ' 保存用户初始选中的单元格
    
    ' 先保存用户当前选中的单元格，这是唯一一次依赖UI状态的操作
    Set originalCell = ActiveCell
    
    i = 2
    j = 0
    PB1 = 0
    Set Rng2 = Nothing ' 修正原代码中未声明的Rng变量，改为Rng2
    
    ' NEW PAGE
    ' Check for page height breach
    PB1 = originalCell.Row ' 用保存的单元格获取行号，替代Selection.Row
    i = 1
    
    ' Loop how many extra blank rows you want below the bottom spec on a page
    Do Until i = 17
        ' If there's a page break above row i
        If Rows(PB1).Offset(i, 0).EntireRow.PageBreak <> xlPageBreakNone Then
            ' Copy blank row
            Range("A1000:A1006").EntireRow.Copy
            ' 在初始位置插入行，用originalCell定位
            originalCell.EntireRow.Insert Shift:=xlDown
            ' Insert page break just above the new area
            Rows(PB1).Offset(4, 0).PageBreak = xlPageBreakManual
            ' 更新originalCell的引用（因为插入行后，原位置的单元格会下移）
            Set originalCell = originalCell.Offset(7, 0)
            i = 17
        Else
            ' Increment i to prevent infinite loop
            i = i + 1
        End If
    Loop
    
    ' INSERT NEW AREA
    ' Copy blank new area
    ActiveWorkbook.Names("Temp_NewArea").RefersToRange.EntireRow.Copy
    ' 在保存的单元格位置插入行，替代ActiveCell
    originalCell.EntireRow.Insert Shift:=xlUp
    
    ' ASSIGN NEW AREA WITH A NEW NAME
    SR = ActiveWorkbook.Names("Spec1").RefersToRange.Address
    ' 用originalCell定位目标区域，替代ActiveCell.Offset(...).Select
    Dim targetRange As Range
    Set targetRange = originalCell.Offset(2, 7).Resize(4, 1)
    
    ' ADD THE NEW AREA TO SPECIFIED_RANGES
    ' Add that specified range to string SR, comma separated
    SR = SR & ":" & Range("Quote_End").Offset(-3, 1).Address
    ' Create/Overwrite (by default) Specified_Areas range using string SR
    ActiveWorkbook.Names.Add "Specified_Ranges", "=" & SR
    
    ' 可选：如果需要最后回到初始选中的位置（或者新的位置），用Activate
    originalCell.Offset(4, -7).Activate
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
End Sub

重构的关键改进点 #

• 移除所有Select/Activate操作：这些操作不仅会导致UI闪烁，更是引发状态依赖问题的根源，直接用Range对象定位即可。
• 固定初始位置：只在代码开头获取一次用户的选中位置，后续所有操作都基于这个保存的Range对象，即使插入行导致单元格位置变化，也可以通过Offset更新这个对象的引用。
• 修正未声明变量：原代码中Rng变量未声明，改为Rng2并显式声明，避免隐式变量带来的潜在问题。

这样修改后，代码会变得更稳定，彻底消除因ActiveCell/Selection状态变化导致的间歇性崩溃问题。

内容的提问来源于stack exchange，提问作者jfgoodhew1