在

时间：2019-01-28 18:31:20

标签： excel vba

在Excel VBA中，如果变量为Excel.Range，并且其引用的范围已删除，则它将丢失其引用。任何访问变量的尝试都会导致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.

是否有一种方法可以在没有错误处理程序的情况下测试“丢失参考”的状态？？

测试Nothing，Vartype（）和Typename（）都没有用，因为变量仍然是Range。我在对象浏览器中逐字阅读了所有Excel.Application，但未找到任何内容。也许有些东西我在忽略..？例如来自excel的史前版本的那些奇怪的残留函数之一，例如ExecuteExcel4Macro（）..

我已经在Google上搜索了此问题的答案，但没有发现任何帮助。

编辑：

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

  • 我确实知道有时错误处理程序是最快的方法，还是唯一的方法。但这不是最优雅的方式。看来，好吧……对我来说是粗鲁的。这就像粉刷栅栏和画猫的画像之间的区别。 =-）
  • 我避免错误处理程序的另一个原因是教育。很多时候，当寻找替代方案时，我会发现属性，过程，对象，甚至是我以前从未了解过的整个库。这样做的话，我发现有更多的防弹衣可以用来防弹我的代码。

3 个答案:

答案 0 :(得分：1)

这是一种应该能够解决该问题的方法，尽管对于检查它是否被自行删除并不是一个很好的解决方案。我认为错误处理可能是您最好的方法。

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

答案 1 :(得分：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访问）。

UPDATE 20年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

UPDATE 20 Aug 02'最后，我使用下面的代码来检测已删除的行并从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

答案 2 :(得分：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
相关问题
最新问题