I'm using the single cell named range RowMarker trick to keep track of when users are adding or deleting rows.
This happens in the Worksheet_Change event. When a user adds a new row a dropdown (validation) is added in Column B, populated with values from a table in another sheet. When an option in this dropdown is selected another dropdown is added to column F with dynamic data.
At this point the code throws:
Run-time error '-2147417848 (80010108)':
Method 'RefersToRange' of object 'Name' failed
As far as I understand it, this means that the named range can't be found. However, if I check the Name Manager it exists and if I iterate over the named ranges in the Sheet it is listed with the correct address.
Workbook code:
Option Explicit
Private Sub Workbook_Open()
' Bug in Excel:
' The Worksheet_Activate event does not fire for the sheet that is active
' when the workbook is opened, so call it explicitly. Make sure that
' Worksheet_Activate() is declared as Public.
' Ignore ActiveSheets without (Public) Worksheet_Activate()
On Error Resume Next
Call ActiveSheet.Worksheet_Activate
On Error GoTo 0
End Sub
WorkSheet code:
Option Explicit
Public lngRow As Long
Public Sub Worksheet_Activate()
' Set named marker to track if we add or delete rows
Dim rng1 As Range
Me.Names.Add Name:="RowMarker", RefersTo:=Range("$A$1000")
Set rng1 = Me.Names("RowMarker").RefersToRange
lngRow = rng1.Row
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
' Check if row is added or deleted
Dim isRowAdded As Boolean, isRowDeleted As Boolean, isDoelstellingAdded As Boolean
Dim rng1 As Range
Dim nm As Name
For Each nm In ActiveSheet.Names
Debug.Print (nm.Name & ": " & nm.RefersTo)
Next nm
Set rng1 = Me.Names("RowMarker").RefersToRange
'Set rng1 = Worksheets("Acties (ISO)").Range("RowMarker")
'Set rng1 = ThisWorkbook.Worksheets("Acties (ISO)").Range("RowMarker")
If rng1.Row < lngRow Then
isRowDeleted = True
ElseIf rng1.Row > lngRow Then
isRowAdded = True
End If
' Check if new Doelstelling was entered in the last row of the table -> skip Insertion and PastInsertion
' Check if we're in an empty row at the bottom of the table
Dim totalTableRows As Long
totalTableRows = getTotalTableRows
If Target.Row = totalTableRows + 1 And Target.Column = 2 And isRowAdded = False Then ' + 1 for sheet header
isDoelstellingAdded = True
GoTo newDoelstelling
End If
If rng1.Row = lngRow Then GoTo Insertion
lngRow = rng1.Row
Insertion:
Dim dsSelectCell As Range
Set dsSelectCell = Me.Cells(ActiveCell.Row, 2)
' Skip section if we're not adding a row
If isRowAdded = False Then GoTo PastInsertion
' Get Doelstellingen from sheet Keuzelijsten as named range
Dim rngOptions As Range
Dim rowsOptions As Long
Dim wsKeuzes As Worksheet
Set wsKeuzes = ThisWorkbook.Worksheets("Keuzelijsten")
rowsOptions = wsKeuzes.UsedRange.Rows.Count
Set rngOptions = wsKeuzes.Range("B2:B" & rowsOptions)
ActiveWorkbook.Names.Add "dsOptions", rngOptions
' Insert dropdown with Doelstelling names as options
dsSelectCell.Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=dsOptions"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
PastInsertion:
' Exit early if we're adding OR deleting a row OR if no Doelstelling has been set
If isRowAdded = True Or isRowDeleted = True Or IsEmpty(dsSelectCell) Then Exit Sub
' Get all Actieplannen for selected Doelstelling as dictionary
Dim dictPlannen As Scripting.Dictionary
Set dictPlannen = getPlansDictionary(Me.Cells(ActiveCell.Row, 2).Value)
' Insert dropdown with Actieplan names
If Not Intersect(Target, dsSelectCell) Is Nothing Then
' Convert plannen dictionary to array
Dim arrPlannen() As String
ReDim arrPlannen(dictPlannen.Count)
Dim j As Long
For j = 0 To dictPlannen.Count - 1
arrPlannen(j) = dictPlannen.Items(j)
Next j
' Insert dropdown with Actieplan names as options
dsSelectCell.Offset(0, 4).Select
' Remove existing dropdown before inserting new one
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Join(arrPlannen, ",") & ",Nieuw"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
GoTo endOfSub
End If
If Not Intersect(Target, dsSelectCell.Offset(0, 4)) Is Nothing Then
' Prevent looping when Nieuw changes to new Actieplan value
Application.EnableEvents = False
Dim colToSelect As Integer
Dim selectionID As String
' On selecting Nieuw insert sequential Actieplan
If Target.Value = "Nieuw" Then
Dim nrToIterate As String
nrToIterate = Right(dictPlannen.Items(dictPlannen.Count - 1), 2)
nrToIterate = Format(CStr(nrToIterate + 1), "00")
Target.Offset(0, 1).Value = 0
Target.Value = "P" & nrToIterate
colToSelect = 7
selectionID = Target.Offset(0, -5).Value
Else
' On selecting Actieplan get dictionary of Actie volgnummers
Dim dictActionNrs As Scripting.Dictionary
Set dictActionNrs = getActionNrsDictionary(ActiveSheet.Cells(ActiveCell.Row, 2).Value, ActiveSheet.Cells(ActiveCell.Row, 6).Value)
' Insert sequential Actie volgnummer in column G
Target.Offset(0, 1).Value = dictActionNrs(dictActionNrs.Count - 1) + 1
Target.Offset(0, 4).Select
colToSelect = 8
selectionID = Target.Offset(0, -5).Value
End If
Call afterFullDPAInsert(selectionID, colToSelect)
GoTo endOfSub
End If
newDoelstelling:
' Skip if we're not adding a new Doelstelling
If isDoelstellingAdded = False Then GoTo endOfSub
' Prevent looping when entering values
Application.EnableEvents = False
' Set Actieplan en Actievolgnummer values
Target.Offset(0, 4).Value = "P00"
Target.Offset(0, 5).Value = "0"
' Add new Doelstelling to table in sheet Keuzelijsten
Dim newDoelstelling As String, newDoelstellingCode As String
newDoelstelling = Target.Value
newDoelstellingCode = Left(newDoelstelling, 3)
Dim wsKeuzelijsten As Worksheet
Dim tblKeuzes As ListObject
Dim newRow As ListRow
Set wsKeuzelijsten = ThisWorkbook.Worksheets("Keuzelijsten")
Set tblKeuzes = wsKeuzelijsten.ListObjects("Tabel_DS")
Set newRow = tblKeuzes.ListRows.Add
With newRow
.Range(1) = newDoelstellingCode
.Range(2) = newDoelstelling
End With
' Sort table DS in sheet Keuzelijsten
With wsKeuzelijsten
.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Sort key1:=.Range("A2"), _
order1:=xlAscending, _
Header:=xlGuess
End With
Call afterFullDPAInsert(Target.Offset(0, -1).Value, 7)
endOfSub:
' Insert today's date in column E
ActiveSheet.Cells(ActiveCell.Row, 5).Value = Format(Date, "d/m/yyyy")
Application.EnableEvents = True
End Sub
Function getTotalTableRows() As Long
Dim tbl As ListObject
Dim tableTotalRows As Long
Set tbl = Me.ListObjects("Tabel_acties")
tableTotalRows = tbl.Range.Rows.Count
getTotalTableRows = tableTotalRows
End Function
Function getPlansDictionary(doelstelling As String) As Dictionary
Dim rowsDoelen As Long
rowsDoelen = Me.UsedRange.Rows.Count
Dim dictPlannen As Scripting.Dictionary
Set dictPlannen = New Scripting.Dictionary
Dim i As Integer
' Loop through all rows to find rows with selected Doelstelling
For i = 3 To rowsDoelen
If ActiveSheet.Cells(i, 2).Value = doelstelling Then
' Add all plans for selected Doelstelling to dictionary
' Don't add "Nieuw" or empty or duplicate plans
If Not ActiveSheet.Cells(i, 6).Value = "Nieuw" And Not ActiveSheet.Cells(i, 6).Value = "" And Not dictPlannen.Exists(ActiveSheet.Cells(i, 6).Value) Then
With dictPlannen
.Item(ActiveSheet.Cells(i, 6).Value) = ActiveSheet.Cells(i, 6).Value
End With
End If
End If
Next i
Set getPlansDictionary = dictPlannen
End Function
Function getActionNrsDictionary(doelstelling As String, actionPlan As String) As Dictionary
Dim rowsDoelen As Long
rowsDoelen = ActiveSheet.UsedRange.Rows.Count
Dim dictActionNrs As Scripting.Dictionary
Set dictActionNrs = New Scripting.Dictionary
Dim i As Integer
' Loop through all rows to find rows with selected Doelstelling
For i = 3 To rowsDoelen
If ActiveSheet.Cells(i, 2).Value = doelstelling And ActiveSheet.Cells(i, 6).Value = actionPlan Then
' Add all Actievolgnummers for selected Doelstelling+Actieplan to dictionary
' Don't add empty volgnummers
If Not ActiveSheet.Cells(i, 6).Value = "" Then
With dictActionNrs
.Item(ActiveSheet.Cells(i, 7).Value) = ActiveSheet.Cells(i, 7).Value
End With
End If
End If
Next i
Set getActionNrsDictionary = dictActionNrs
End Function
Function afterFullDPAInsert(selectionID As String, colToSelect As Integer)
With Me
' Sort table after DPA is complete so column A remains sequential
.Range("A3", .Cells(.Rows.Count, "A").End(xlUp)).Sort key1:=Range("A3"), _
order1:=xlAscending, _
Header:=xlGuess
' Select correct cell after sorting
Dim i As Long
For i = 3 To .UsedRange.Rows.Count
If Me.Cells(i, 1).Value = selectionID Then Me.Cells(i, colToSelect).Select
Next i
' Trigger Autofit height on selected row
.Range("A3:A" & .UsedRange.Rows.Count).EntireRow.AutoFit
End With
End Function
I've tried every way to define named ranges. I don't understand how this line can resolve in the first change event, yet fail in the subsequent event.
I tried:
Set rng1 = Worksheets("Acties (ISO)").Range("RowMarker")Set rng1 = Sheets("Acties (ISO)").Range("RowMarker")Set rng1 = ThisWorkbook.Sheets("Acties (ISO)").Range("RowMarker")Set rng1 = ThisWorkbook.Worksheets("Acties (ISO)").Range("RowMarker")I uploaded a reduced testcase which throws the same errors here: WeTransfer Verbeterplan-TEST.xlsm.
I also updated the code above to show everything.
There was an infinite loop where the change event kept getting called over and over, hence the crashes.