In Excel VBA, how can I test if an Excel.Range object variable loses its reference without raising runtime error 424..?

Question

In Excel VBA, if a variable is Excel.Range, and the range it refers to is deleted, it loses its reference. Any attempt to access the variable results in Runtime Error 424: object required.

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.

Is there a way to test for this state of "lost reference" without an error handler..?

Testing Nothing, Vartype(), and Typename() were all not useful because the variable is still a Range. I literally read through all of Excel.Application in the Object browser, but found nothing. Perhaps there's something I'm overlooking..? Such as one of those strange vestigial functions from prehistoric versions of Excel, like ExecuteExcel4Macro()..?

I've searched Google for the answer to this question, but didn't find anything helpful.

EDIT:

Some have asked why I'm trying to avoid an error handler. This is my normal programming philosophy for a couple reasons:

I do recognize that sometimes an error handler is the quickest way, or the only way. But it's not the most elegant way. It just seems, well...crude to me. It's like the difference between white-washing a picket fence and painting a portrait of my cat. =-)
The other reason I avoid error handlers is education. Many times when searching for an alternative, I'll discover properties, procedures, objects, or even entire libraries that I never knew before. And in doing so I find more armor with which to bulletproof my code.

This appears to be an Excel bug - it should be decrementing the reference count when the underlying object is destroyed. — Comintern
– Comintern, Commented Jan 28, 2019 at 18:40
That seems true if the range reference points to a cell somewhere out in the middle of the sheet. If a row or column gets deleted, the cell simply moves up, down, left, or right. But...if the cell is in what was deleted, it's not simply moving... it's gone. Then what..? How would it be incremented or decremented anywhere..? That would be pointing it to a different cell. For example, what if the deleted cell had a Sum() formula, and the one it gets redirected to has Avg()..? All heck would break loose in that sheet. — spinjector
– spinjector, Commented Jan 28, 2019 at 18:51
I doubt anything other than error handling can deal with that. — Mathieu Guindon
– Mathieu Guindon, Commented Jan 28, 2019 at 19:03
I suspect that @Comintern is right that this is an outright bug in Excel VBA. If so, it seems unlikely that anything other than error trapping can guard against it. — John Coleman
– John Coleman, Commented Jan 28, 2019 at 19:10

Ryan Wildry · Accepted Answer · 2019-01-29 13:10:38Z

Here's an approach that should be able to workaround the issue, although it isn't a great solution for checking if it was removed by itself. I think error handling is probably your best approach.

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

Also, here is a more function oriented approach which may be a slightly better approach to add to your codebase. Again, not ideal, but it should not require an error handler.

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

EvE · Accepted Answer · 2020-05-31 13:37:04Z

0

Just in case someone needs a solution for this problem and doesn't mind using the error handler.

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

edited May 31, 2020 at 13:37

answered May 31, 2020 at 12:18

EvE

7503 silver badges13 bronze badges

Comments

robertocm · Accepted Answer · 2020-08-02 13:51:45Z

An example using a range name:

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:=""

Below an example of a sheet module to synchronize from an excel listobject to a database table (ms access).

UPDATE Jul 05, 20': some testing with the code below seems to shows a lost of info about the counter of selected rows/columns in the "names" editor window panel (top left, next to formula editor) in cases of multiple cell selections.

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

UPDATE Aug 02 '20 Finally i'm using the code below for detecting deleted rows and upward synchronizing from an excel ListObject table to a database table:

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

Collectives™ on Stack Overflow

In Excel VBA, how can I test if an Excel.Range object variable loses its reference without raising runtime error 424..?

3 Answers 3

Comments

Comments

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

Comments

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related