如何修改VBA代码插入行至新工作表不复制命名范围或自动确认提示？

执行以下VBA代码将选中行插入至名为CSV的工作表时，会弹出关于命名范围的提示框，需求是修改代码实现插入行时不复制命名范围，或让代码自动确认该提示框无需手动操作。

原代码：

Sub CopyToNewSheet()

Dim Last_Row As Long
Last_Row = Sheets("CSV").Cells(Rows.Count, 1).End(xlUp).row

Dim c As Range, d, a As Range
On Error Resume Next
Set c = Application.InputBox("Select the row(s) to be copied.", Type:=8)
d = Application.InputBox("Enter the row number where to insert." & vbNewLine & vbNewLine & "The next free row is " & Last_Row + 1 & ".", Type:=1)
On Error GoTo 0
If c Is Nothing Then
    MsgBox "The source rows were not selected"
    Exit Sub
ElseIf TypeName(d) = "Boolean" Then
    MsgBox "The destination row was not entered"
    Exit Sub
End If

For Each a In c.Areas
    a.EntireRow.Copy
    Sheets("CSV").Rows(Val(d)).EntireRow.Insert
Next
Application.CutCopyMode = False
Application.GoTo Sheets("CSV").Range("A1"), True
Rows("5:100").RowHeight = 15
End Sub

方案一：自动跳过命名范围提示框 #

通过禁用Excel的显示提示设置，让代码自动确认弹窗，操作完成后恢复默认设置即可。

修改后的代码：

Sub CopyToNewSheet()
    Dim Last_Row As Long
    Last_Row = Sheets("CSV").Cells(Rows.Count, 1).End(xlUp).Row

    Dim c As Range, d, a As Range
    On Error Resume Next
    Set c = Application.InputBox("Select the row(s) to be copied.", Type:=8)
    d = Application.InputBox("Enter the row number where to insert." & vbNewLine & vbNewLine & "The next free row is " & Last_Row + 1 & ".", Type:=1)
    On Error GoTo 0
    
    If c Is Nothing Then
        MsgBox "The source rows were not selected"
        Exit Sub
    ElseIf TypeName(d) = "Boolean" Then
        MsgBox "The destination row was not entered"
        Exit Sub
    End If

    ' 禁用所有Excel提示弹窗
    Application.DisplayAlerts = False
    For Each a In c.Areas
        a.EntireRow.Copy
        Sheets("CSV").Rows(Val(d)).EntireRow.Insert
    Next
    ' 恢复提示弹窗默认设置
    Application.DisplayAlerts = True

    Application.CutCopyMode = False
    Application.GoTo Sheets("CSV").Range("A1"), True
    Rows("5:100").RowHeight = 15
End Sub

方案二：不复制命名范围，仅复制行内容 #

如果希望从根源避免携带命名范围关联，可以放弃直接复制整行的方式，改为先插入空行，再复制原行的内容（值、格式、公式等），这样就不会触发命名范围的提示。

修改后的代码：

Sub CopyToNewSheet()
    Dim Last_Row As Long
    Last_Row = Sheets("CSV").Cells(Rows.Count, 1).End(xlUp).Row

    Dim c As Range, d, a As Range
    On Error Resume Next
    Set c = Application.InputBox("Select the row(s) to be copied.", Type:=8)
    d = Application.InputBox("Enter the row number where to insert." & vbNewLine & vbNewLine & "The next free row is " & Last_Row + 1 & ".", Type:=1)
    On Error GoTo 0
    
    If c Is Nothing Then
        MsgBox "The source rows were not selected"
        Exit Sub
    ElseIf TypeName(d) = "Boolean" Then
        MsgBox "The destination row was not entered"
        Exit Sub
    End If

    For Each a In c.Areas
        ' 插入与选中行数量一致的空行
        Sheets("CSV").Rows(Val(d)).Resize(a.Rows.Count).EntireRow.Insert
        ' 复制原行内容到新插入的行，可根据需求调整粘贴类型
        a.EntireRow.Copy
        Sheets("CSV").Rows(Val(d)).Resize(a.Rows.Count).PasteSpecial xlPasteAllExceptBorders
    Next

    Application.CutCopyMode = False
    Application.GoTo Sheets("CSV").Range("A1"), True
    Rows("5:100").RowHeight = 15
End Sub

粘贴类型说明 #

可以根据需求替换xlPasteAllExceptBorders为其他粘贴类型：

• xlPasteValues：仅复制单元格值
• xlPasteValuesAndNumberFormats：复制值和数字格式
• xlPasteFormats：仅复制格式
• xlPasteAll：复制全部内容（不含命名范围关联）

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