在Excel VBA中，如何测试Excel.Range对象变量是否失去其引用而不引发运行时错误424？

Question

在Excel VBA中，如何测试Excel.Range对象变量是否失去其引用而不引发运行时错误424？

8

在Excel VBA中，如果一个变量是Excel.Range类型，并且它所引用的单元格范围被删除，则它将失去引用。任何尝试访问此变量都会导致"运行时错误424：需要对象"的错误。

Dim rng As Range
Set rng = Sheet1Range("A1")
Sheet1.Rows(1).Delete       'Range has been deleted.
Debug.Print rng.Address()   'Any access attempt now raises runtime error 424.

有没有一种方法可以在不使用错误处理程序的情况下测试"丢失引用"的状态..？

测试Nothing、Vartype()和Typename()都没有用，因为变量仍然是一个Range。我已经在对象浏览器中阅读了所有的Excel.Application，但没有找到任何有用的信息。也许有些东西我忽略了..？比如那些来自史前版本Excel的奇怪遗传功能，比如ExecuteExcel4Macro()..？

我已经在谷歌上搜索了这个问题的答案，但没有找到任何有用的信息。

编辑：

有些人问我为什么要避免使用错误处理程序。这是我的正常编程哲学，原因有几个：

- 我承认有时错误处理程序是最快的方式，或者是唯一的方式。但它不是最优雅的方式。它似乎很...粗糙。这就像是在白色围栏上涂白颜料，而不是画一幅我的猫的肖像。=-) - 我避免使用错误处理程序的另一个原因是教育。很多时候，在寻找替代方案时，我会发现之前从未了解过的属性、过程、对象，甚至整个库。通过这样做，我可以找到更多的防弹代码的装备。

- spinjector

2

这似乎是一个Excel的bug - 当底层对象被销毁时，它应该减少引用计数。 - Comintern

1

如果范围引用指向工作表中间的某个单元格，那么这似乎是正确的。如果删除了一行或一列，该单元格只会向上、向下、向左或向右移动。但是...如果该单元格位于已删除的区域内，它不仅仅是移动...它消失了。那么怎么办呢..？它如何在任何地方增加或减少..？这将指向一个不同的单元格。例如，如果删除的单元格具有Sum()公式，并且被重定向到具有Avg()的单元格，则该工作表将出现问题。 - spinjector

2

这不就是导致 #REF! 错误的原因吗？ - Mathieu Guindon

5

除了错误处理，我怀疑其他的方法都无法应对这个问题。 - Mathieu Guindon

2

我怀疑@Comintern是正确的，这是Excel VBA中的一个明显的错误。如果是这样，似乎除了错误捕获之外，没有其他任何东西可以防范它。 - John Coleman

显示剩余7条评论

3个回答

0

如果有人需要解决这个问题，并且不介意使用错误处理程序，可以参考以下解决方案。

Option Explicit

Public Sub Example()
    Dim rng1 As Range, rng2 As Range

    Set rng1 = Range("A1")
    Set rng2 = Range("A2")
    ActiveSheet.Rows(1).Delete ' rng1 will loose its reference

    Debug.Print "rng1 has reference? : " & RangeHasReference(rng1)
    Debug.Print "rng2 has reference? : " & RangeHasReference(rng2)
End Sub

Private Function RangeHasReference(rng As Range) As Boolean
    Dim Creator As Long
    On Error Resume Next
    Creator = rng.Creator ' try access some property
    RangeHasReference = (Err.Number <> 424)
End Function

- EvE

0

使用范围名称的示例：

Dim ws As Worksheet, rng As Range, nm As Name
Set ws = ActiveSheet
Set rng = ws.Range("A2")
Names.Add Name:="testName", RefersTo:=rng
Set nm = Application.Names("testName")

ws.Rows(2).Delete       'Range has been deleted.

If InStr(1, nm.RefersTo, "#REF!") > 0 Then
'If InStr(1, Names("testName").RefersTo, "#REF!") > 0 Then
    Debug.Print "lost reference"
Else
    Debug.Print rng.Address()
End If

nm.Delete
'Names.Add Name:="testName", RefersTo:=""

以下是一个示例表模块，用于将Excel列表对象与数据库表（MS Access）同步。

更新于2020年7月5日：使用下面的代码进行一些测试似乎显示在多个单元格选择的情况下，“名称”编辑器窗口面板中所选行/列的计数器信息丢失。

Private IdAr As Variant, myCount As Integer
Private Sub Worksheet_Activate()
Names.Add Name:="myName", RefersTo:=Selection, Visible:=False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count = Me.Rows.Count Then Exit Sub
On Error GoTo ExceptionHandling

Names.Add Name:="myName", RefersTo:=Target, Visible:=False

If Not Application.Intersect(Target, Me.ListObjects("Table2").DataBodyRange) Is Nothing Then
    Dim tblRow As Long, y As Integer, i As Integer
    tblRow = Target.Row - Me.ListObjects("Table2").HeaderRowRange.Row
    y = Target.Rows.Count
    If y > 1 Then
        ReDim IdAr(0 To y - 1)
        For i = 0 To y - 1
            IdAr(i) = Me.ListObjects("Table2").ListColumns("ID").DataBodyRange(tblRow + i)
        Next i
    Else
        'If Application.CutCopyMode = False Then
            IdAr = Me.ListObjects("Table2").ListColumns("ID").DataBodyRange(tblRow).Value
       'End If
    End If
End If

CleanUp:
    On Error Resume Next
    Exit Sub
ExceptionHandling:
    MsgBox "Error: " & Err.Description
    Resume CleanUp
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ExceptionHandling
Application.EnableEvents = False

If Not Application.Intersect(Target, Me.ListObjects("Table2").DataBodyRange) Is Nothing Then
    Dim myCell As Range

    For Each myCell In Target
        If Not Application.Intersect(myCell, Me.ListObjects("Table2").ListColumns("ID").DataBodyRange) Is Nothing Then
            If InStr(1, Names("myName").RefersTo, "#") > 0 Then
                Debug.Print "Lost reference"
                Delete_record
                myCount = myCount + 1
                Cancelado = True
            Else
                If myCell.Text = vbNullString Then
                    Debug.Print "Selecting listObject row and clear contents"
                    Delete_record
                    myCount = myCount + 1
                    Cancelado = True
                End If
            End If
        Else
            If Cancelado = False Then
                If Not Application.Intersect(myCell, Me.Range("Table2[[FIELD1]:[FIELD3]]")) Is Nothing Then Update_record myCell
            End If
        End If
    Next myCell
End If

CleanUp:
    On Error Resume Next
    myCount = 0
    Application.EnableEvents = True
    Exit Sub
ExceptionHandling:
    MsgBox "Error: " & Err.Description
    Resume CleanUp
End Sub
Sub Update_record(myCell As Range)
On Error GoTo ExceptionHandling

Dim tblRow As Long, IdTbl As Long, sField As String, sSQL As String
sField = Me.ListObjects("Table2").HeaderRowRange(myCell.Column)
tblRow = myCell.Row - Me.ListObjects("Table2").HeaderRowRange.Row
IdTbl = Me.ListObjects("Table2").ListColumns("ID").DataBodyRange(tblRow).Value

'Dim cnStr As String
'cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPath & ";Jet OLEDB:Database Password=123"
'Dim cn As ADODB.Connection
'Set cn = New ADODB.Connection
'cn.CursorLocation = adUseServer
'cn.Open cnStr

If IdTbl > 0 Then
    sSQL = "UPDATE MYTABLE SET " & sField & " = '" & myCell.Value & "' WHERE ID = " & Me.ListObjects("Table2").ListColumns("ID").DataBodyRange(tblRow).Value
    MsgBox sSQL
    'Dim cmd As ADODB.Command
    'Set cmd = New ADODB.Command
    'Set cmd.ActiveConnection = cn
    'cmd.CommandText = sSQL
    'cmd.Execute , , adCmdText + adExecuteNoRecords
    ''cn.Execute sSQL, RecsAffected 'alternative to Command
    ''Debug.Print RecsAffected
Else
    sSQL = "SELECT ID, " & sField & " FROM MYTABLE"
    MsgBox sSQL
    'Dim rst As ADODB.Recordset
    'Set rst = New ADODB.Recordset
    'rst.Open sSQL, cn, adOpenForwardOnly, adLockOptimistic, adCmdText
    'cn.BeginTrans
    'rst.AddNew
    'rst(sField).Value = myCell.Value
    'rst.Update
    'IdTbl = rst(0).Value
    'MsgBox "New Auto-increment value is: " & IdTbl
    'tbl.ListColumns("ID").DataBodyRange(Fila) = IdTbl
    'rst.Close
    'cn.CommitTrans
End If

CleanUp:
    On Error Resume Next
    cn.Close
    Exit Sub
ExceptionHandling:
    MsgBox "Error: " & Err.Description & vbLf & Err.Number
    Resume CleanUp
    Resume 'for debugging
End Sub
Sub Delete_record()
Dim sSQL As String

If IsArray(IdAr) Then
    sSQL = "DELETE FROM MYTABLE WHERE ID = " & IdAr(myCount)
    MsgBox sSQL
Else
    sSQL = "DELETE FROM MYTABLE WHERE ID = " & IdAr
    MsgBox sSQL
End If
End Sub

更新于2020年8月2日，我最终使用以下代码检测已删除的行，并从Excel ListObject表向数据库表进行向上同步：

Private IdAr As Variant, tbRows As Integer, myCount As Integer, Cancelado As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count = Me.Rows.Count Then Exit Sub
On Error GoTo ExceptionHandling

If Not Application.Intersect(Target, Me.ListObjects("Table1").DataBodyRange) Is Nothing Then
    Dim tblRow As Long, y As Integer, i As Integer
    tblRow = Target.Row - Me.ListObjects("Table1").HeaderRowRange.Row
    y = Target.Rows.Count
    If y > 1 Then
        ReDim IdAr(0 To y - 1)
        For i = 0 To y - 1
            IdAr(i) = Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow + i)
        Next i
    Else
        'If Application.CutCopyMode = False Then
            IdAr = Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow).Value
       'End If
    End If
    tbRows = Me.ListObjects("Table1").ListRows.Count
End If

CleanUp:
    On Error Resume Next
    Exit Sub
ExceptionHandling:
    MsgBox "Error: " & Err.Description
    Resume CleanUp
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ExceptionHandling
Application.EnableEvents = False

If Not Application.Intersect(Target, Me.ListObjects("Table1").DataBodyRange) Is Nothing Then
    Cancelado = False
    Dim myCell As Range
    For Each myCell In Target
        If Not Application.Intersect(myCell, Me.ListObjects("Table1").ListColumns("ID").DataBodyRange) Is Nothing Then
            If Me.ListObjects("Table1").ListRows.Count > tbRows Then
                Cancelado = True
            Else
                If Me.ListObjects("Table1").ListRows.Count = tbRows Then
                    If myCell.Text = vbNullString Then
                        Debug.Print "Selected ListObject Row and Cleared Contents"
                        Cancelado = True
                        Delete_record
                        myCount = myCount + 1
                    End If
                Else
                    Cancelado = True
                    Debug.Print "ListObject Row Deleted"
                    Delete_record
                    myCount = myCount + 1
                End If
            End If
        Else
            If Cancelado = False Then
                If Not Application.Intersect(myCell, Me.Range("Table1[[FIELD1]:[FIELD3]]")) Is Nothing Then Update_record myCell
            End If
        End If
    Next myCell
End If

CleanUp:
    On Error Resume Next
    myCount = 0
    Application.EnableEvents = True
    Exit Sub
ExceptionHandling:
    MsgBox "Error: " & Err.Description & vbLf & Err.Number
    Resume CleanUp
    Resume 'for debugging
End Sub
Sub Update_record(myCell As Range)
On Error GoTo ExceptionHandling

Dim tblRow As Long, IdTbl As Long, sField As String, sSQL As String
sField = Me.ListObjects("Table1").HeaderRowRange(myCell.Column)
tblRow = myCell.Row - Me.ListObjects("Table1").HeaderRowRange.Row
IdTbl = Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow).Value

'Dim cnStr As String
'cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sPath & ";Jet OLEDB:Database Password=123"
'Dim cn As ADODB.Connection
'Set cn = New ADODB.Connection
'cn.CursorLocation = adUseServer
'cn.Open cnStr

If IdTbl > 0 Then
    sSQL = "UPDATE MYTABLE SET " & sField & " = '" & myCell.Value & "' WHERE ID = " & Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow).Value
    MsgBox sSQL
    'Dim cmd As ADODB.Command
    'Set cmd = New ADODB.Command
    'Set cmd.ActiveConnection = cn
    'cmd.CommandText = sSQL
    'cmd.Execute , , adCmdText + adExecuteNoRecords
    ''cn.Execute sSQL, RecsAffected 'alternative to Command
    ''Debug.Print RecsAffected
Else
    sSQL = "SELECT ID, " & sField & " FROM MYTABLE"
    MsgBox sSQL
    'Dim rst As ADODB.Recordset
    'Set rst = New ADODB.Recordset
    'rst.Open sSQL, cn, adOpenForwardOnly, adLockOptimistic, adCmdText
    'cn.BeginTrans
    'rst.AddNew
    'rst(sField).Value = myCell.Value
    'rst.Update
    'IdTbl = rst(0).Value
    'MsgBox "New Auto-increment value is: " & IdTbl
    'Me.ListObjects("Table1").ListColumns("ID").DataBodyRange(tblRow) = IdTbl
    'rst.Close
    'cn.CommitTrans
End If

CleanUp:
    On Error Resume Next
    If Not cn Is Nothing Then
        If cn.State = adStateOpen Then cn.Close
    End If
    'DriveMapDel
    'https://codereview.stackexchange.com/questions/143895/making-repeated-adodb-queries-from-excel-sql-server
    '... get rid of the redundant assignments to Nothing; the objects are going out of scope at End Sub, they're being destroyed anyway.
    'Set rst = Nothing
    'Set cmd = Nothing
    'Set cn = Nothing
    Exit Sub
ExceptionHandling:
    MsgBox "Error: " & Err.Description & vbLf & Err.Number
    Resume CleanUp
    Resume 'for debugging
End Sub
Sub Delete_record()
Dim sSQL As String

If IsArray(IdAr) Then
    sSQL = "DELETE FROM MYTABLE WHERE ID = " & IdAr(myCount)
    MsgBox sSQL
Else
    sSQL = "DELETE FROM MYTABLE WHERE ID = " & IdAr
    MsgBox sSQL
End If
End Sub

- robertocm

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Ryan Wildry · Accepted Answer

这里提供了一种方法，应该能够解决问题，但并不是一个很好的解决方案来检查它是否被自动删除。我认为错误处理可能是最好的方法。

原始答案翻译成中文是“最初的回答”。

Sub Example()
    Dim foo1 As Range
    Dim foo2 As Range
    Dim foo3 As Range
    Dim numberOfCells As Long

    Set foo1 = Sheet1.Range("A1")
    Set foo2 = foo1.Offset(1, 0) 'Get the next row, ensure this cell exists after row deletion!
    Set foo3 = Union(foo1, foo2)
    numberOfCells = foo3.Cells.Count

    Debug.Print "There are " & numberOfCells & " cells before deletion"
    Sheet1.Rows(1).Delete

    Debug.Print "There are now " & foo3.Cells.Count & " cells"

    If foo3.Cells.Count <> numberOfCells Then
        Debug.Print "One of the cells was deleted!"
    Else
        Debug.Print "All cells still exist"
    End If
End Sub

此外，这里有一种更注重功能的方法，可能是向您的代码库添加的稍微更好的方法。虽然不是理想的，但它不应该需要错误处理程序。"最初的回答"

Private getRange As Range

Sub Example()
    Dim foo         As Range
    Dim cellCount   As Long

    Set foo = Sheet1.Range("A1")
    cellCount = GetCellCountInUnion(foo)
    Sheet1.Rows(1).Delete

    If Not cellCount = getRange.Cells.Count Then
        Debug.Print "The cell was removed!"
    Else
        Debug.Print "The cell still exists!"
    End If

End Sub

Private Function GetCellCountInUnion(MyRange As Range) As Long
    Set getRange = Union(MyRange, MyRange.Parent.Range("A50000")) ‘second cell in union is just a cell that should exist
    GetCellCountInUnion = getRange.Cells.Count
End Function