Dans Excel VBA, si une variable est Excel.Range et que la plage à laquelle elle fait référence est supprimée, elle perd sa référence. Toute tentative d'accès à la variable entraîne une Erreur d'exécution 424: objet requis .
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.
Existe-t-il un moyen de tester cet état de "référence perdue" sans erreur handler ..?
Tester Rien , Vartype () et Typename () n'étaient pas utiles car la variable est toujours un Range. J'ai lu littéralement tout Excel.Application dans le navigateur d'objets, mais je n'ai rien trouvé. Il y a peut-être quelque chose que je néglige ...? Comme l'une de ces étranges fonctions résiduelles des versions préhistoriques d'Excel, comme ExecuteExcel4Macro () ..?
J'ai recherché sur Google la réponse à cette question, mais je n'ai rien trouvé d'utile. p>
EDIT:
Certains ont demandé pourquoi j'essayais d'éviter un gestionnaire d'erreurs. C'est ma philosophie de programmation normale pour plusieurs raisons:
3 Réponses :
Voici une approche qui devrait permettre de contourner le problème, bien que ce ne soit pas une excellente solution pour vérifier s'il a été supprimé par lui-même. Je pense que la gestion des erreurs est probablement votre meilleure approche.
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
En outre, voici une approche plus orientée fonction qui peut être une approche légèrement meilleure à ajouter à votre base de code. Encore une fois, pas idéal, mais cela ne devrait pas nécessiter de gestionnaire d'erreurs.
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
Un exemple utilisant un nom de plage:
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
Ci-dessous un exemple de module de feuille à synchroniser depuis un objet de liste Excel vers une table de base de données (accès en ms).
UPDATE Jul 05, 20 ': certains tests avec le code ci-dessous semblent montrer une perte d'informations sur le compteur de lignes / colonnes sélectionnées dans le panneau de la fenêtre de l'éditeur "noms" (en haut à gauche, à côté de l'éditeur de formule) en cas de cellules multiples sélections.
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
MISE À JOUR août 02 '20 Enfin, j'utilise le code ci-dessous pour détecter les lignes supprimées et synchroniser vers le haut d'une table Excel ListObject à une table de base de données: p >
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:=""
Juste au cas où quelqu'un aurait besoin d'une solution pour ce problème et que cela ne dérangerait pas d'utiliser le gestionnaire d'erreurs.
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
Cela semble être un bogue Excel - il devrait décrémenter le nombre de références lorsque l'objet sous-jacent est détruit.
Cela semble vrai si la référence de plage pointe vers une cellule quelque part au milieu de la feuille. Si une ligne ou une colonne est supprimée, la cellule se déplace simplement vers le haut, le bas, la gauche ou la droite. Mais ... si la cellule est dans ce qui a été supprimé, elle ne bouge pas simplement ... elle est partie . Alors quoi ..? Comment serait-il incrémenté ou décrémenté n'importe où ..? Ce serait la pointer vers une cellule différente . Par exemple, que se passe-t-il si la cellule supprimée avait une formule
Sum ()et que celle vers laquelle elle est redirigée aAvg ()..? Tout se détacherait dans cette feuille.N'est-ce pas ainsi que les erreurs
#REF!se produisent?Oui, exactement. J'ai eu un moment d'illumination lorsque vous avez dit cela tout à l'heure, mais en vain. J'ai essayé de tester
Range.ErrorspourxlEmptyCellReferences=Truemais cela n'a pas fonctionné non plus. Je suppose que l'objetErreursa disparu avec tout le reste lorsque la variable a perdu sa référence. Si c'était une cellule qui était toujours là, assise avec la valeurREF!, cela fonctionnerait.Je doute que quoi que ce soit d'autre que la gestion des erreurs puisse y remédier.
Je soupçonne que @Comintern a raison de dire qu'il s'agit d'un bogue pur et simple dans Excel VBA. Si tel est le cas, il semble peu probable que quelque chose d'autre que le piégeage d'erreur puisse s'en prémunir.
Juste par curiosité: pourquoi voudriez-vous empêcher le piégeage des erreurs? Est-ce considéré comme une mauvaise habitude?
peut-être / peut-être pas un bogue - la seule gestion d'erreur nécessaire est de vérifier s'il s'agit de la première ligne car par défaut, Excel déplace les lignes vers le haut une fois supprimées. Donc, si vous supprimez A2, votre ligne devient A1, il n'y a pas de ligne A0.
@Sorceri J'ai répliqué cela en supprimant d'autres lignes, c'est-à-dire
Set foo = [2: 2]: Me.Rows (2) .Delete: Debug.Print foo.Address. Lefoo.Addressrenvoie un 424.Oui, je ne pense pas que ce soit une erreur; Je pense que c'est WAD. Voir mon premier commentaire de suivi ci-dessus. @Joost J'évite les gestionnaires d'erreurs pour la fonctionnalité, l'élégance et l'éducation. Voir les paragraphes supplémentaires à ce sujet que j'ai ajoutés à la fin de mon OP.
Voici peut-être un autre exemple classique du cas, que j'ai rencontré en parcourant le post J'obtiens toujours un objet requis sur mon code. Pourquoi? . Au fur et à mesure que je m'intéresse au sujet, quelqu'un pourrait-il me référer à de bonnes lectures sur le sujet.
Pour référence, ce n'est pas un bug, c'est une fonctionnalité. Les instances
Rangesuivent leurs cellules lorsqu'elles se déplacent dans la feuille; naturellement, lorsque les cellules quittent la feuille, l'instanceRangedevient inutilisable.