You did not answer my clarification question...
The next adapted code/solution assumes that you will not have spaces between the categories (the ones starting and ending in *). The following code creates dynamic ranges name, able to automatically update when you delete a row, or write a new string at the end, or in an inserted row.
1. Copy the next declarations on top of a standard module (in the declarations area). Now, you will not define the whole source range, only the starting cell:
```
Option Explicit
Public Const DropDownsSourceRangeName As String = "Angle"
Public Const DropDownsRangeName As String = "DropDownsRange"
Public Const DropDownsSourceSheetName As String = "Angles for estimation"
Public Const DropDownsSheetName As String = "Fundfakt-kateg-vinkl"
Public Const DropDownsSourceRangeAddress As String = "$A$8" ' Not "$A$8:$A$1008"
Public Const DropDownsRangeAddress As String = "$AC$4:$AI$18"
'declarations for the new part:
Public Const DropDownsSourceSheetName2 As String = "Categories for estimation"
Public Const DropDownsSourceSheetName3 As String = "Fundamentals for estimation"
Public Const DropDownsRangeName2 As String = "DropDownsRange1"
Public Const DropDownsRangeName3 As String = "DropDownsRange2"
Public Const DropDownsSourceRangeName2 As String = "Angle1"
Public Const DropDownsSourceRangeName3 As String = "Angle2"
Public Const DropDownsSourceRange2Address As String = "$A$8" ' Not "$A$8:$A$1008"
Public Const DropDownsSourceRange3Address As String = "$A$8" ' Not "$A$8:$A$22"
Public Const DropDownsRange2Address As String = "$Q$4:$W$18"
Public Const DropDownsRange3Address As String = "$A$4:$G$18"
'arrays to keep the necessary above variables in a way to allow iteration, to make the code more compact/elegant
Private arrDrD(), arrSource(), arrAngle(), arrSourceSh(), arrSourceAddr(), arrDropDAddr(), arrDrDRangeAddr()
```
2. Copy the next code inside the standard module where you placed the above declarations:
```
Sub LoadArrays() 'it loads the necessary above declared arrays, to be used in the next procedures
Dim i As Long
arrSourceSh = Array(DropDownsSourceSheetName, DropDownsSourceSheetName2, DropDownsSourceSheetName3)
arrDrD = Array(DropDownsRangeName, DropDownsRangeName2, DropDownsRangeName3)
arrAngle = Array(DropDownsSourceRangeName, DropDownsSourceRangeName2, DropDownsSourceRangeName3)
arrSourceAddr = Array(DropDownsSourceRangeAddress, DropDownsSourceRange2Address, DropDownsSourceRange3Address)
arrDrDRangeAddr = Array(DropDownsRangeAddress, DropDownsRange2Address, DropDownsRange3Address)
End Sub
Sub AddNamedRangeAndSetDropDown(Optional boolNoSource As Boolean = False)
LoadArrays
'if boolNoSource = True source names are not deleted, anymore - No need for that, they are DYNAMIC!
DeleteNamedRanges boolNoSource
Dim i As Long
For i = 0 To UBound(arrDrD)
If Not boolNoSource Then
ThisWorkbook.Names.Add Name:=arrAngle(i), RefersTo:="=Offset('" & arrSourceSh(i) & _
"'!" & arrSourceAddr(i) & ",0,0,COUNTA('" & arrSourceSh(i) & "'!$A:$A)-1,1)" 'Name in source sheets
End If
ThisWorkbook.Names.Add Name:=arrDrD(i), RefersTo:="='" & DropDownsSheetName & "'!" & arrDrDRangeAddr(i) 'where to place the DropDown based on above source
Next i
SetDropDownList
End Sub
Sub DeleteNamedRanges(Optional boolNoSource As Boolean = False)
'if boolNoSource = True source names are not deleted, anymore
On Error GoTo ErrorHandler
Dim i As Long
For i = ThisWorkbook.Names.Count To 1 Step -1
Select Case ThisWorkbook.Names(i).Name
Case IIf(boolNoSource, "", DropDownsSourceRangeName), DropDownsRangeName, _
IIf(boolNoSource, "", DropDownsSourceRangeName2), DropDownsRangeName2, _
IIf(boolNoSource, "", DropDownsSourceRangeName3), DropDownsRangeName3
ThisWorkbook.Names(i).Delete
Case Else
If InStr(ThisWorkbook.Names(i).Name, IIf(boolNoSource, "|#@$|", DropDownsSourceRangeName)) Or _
InStr(ThisWorkbook.Names(i).Name, DropDownsRangeName) Then _
If InStr(ThisWorkbook.Names(i).Name, IIf(boolNoSource, "|#@$|", DropDownsSourceRangeName2)) Or _
InStr(ThisWorkbook.Names(i).Name, DropDownsRangeName2) Then _
If InStr(ThisWorkbook.Names(i).Name, IIf(boolNoSource, "|#@$|", DropDownsSourceRangeName3)) Or _
InStr(ThisWorkbook.Names(i).Name, DropDownsRangeName3) Then _
ThisWorkbook.Names(i).Delete
End Select
Next i
Exit Sub
ErrorHandler:
MsgBox "An error occurred " & Err.Description
End Sub
Sub SetDropDownList() 'No need of any iteration. Validation can be add from all the range, at once!
Dim rngDropDown As Range, i As Long
LoadArrays
For i = 0 To UBound(arrDrDRangeAddr)
Set rngDropDown = Sheets(DropDownsSheetName).Range(arrDrDRangeAddr(i))
With rngDropDown.Validation
.Delete 'clear existed Validation rules, if any
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="=" & arrAngle(i) 'use the named range directly
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = vbNullString '"Select a value"
.ErrorTitle = "Invalid value"
.InputMessage = arrSourceSh(i)
.ErrorMessage = "Select a valid value in the list."
.ShowInput = True
.ShowError = True
End With
Next i
clearNotInListValues 'it clears selected values which are not in the source list, anymore
End Sub
Sub clearNotInListValues()
Dim ws As Worksheet, rng As Range, cel As Range, list
Dim arrIntersect, A As Range, i As Long, dict As New Scripting.dictionary
Const strError As String = "ErrV"
Set ws = ThisWorkbook.Sheets(DropDownsSheetName)
Set rng = Union(ws.Range(DropDownsRangeAddress), _
ws.Range(DropDownsRange2Address), ws.Range(DropDownsRange3Address))
For Each A In rng.Areas 'iterate between the range areas:
list = Application.Transpose(Evaluate(A.Cells(1).Validation.Formula1).Value) 'extract the array from validation list
For Each cel In A.Cells
If cel.Value <> "" Then dict(cel.Value) = vbNullString 'collect all the unique strings from the Area
'except the empty strings
Next cel
If dict.Count > 0 Then 'if at least a value has been found (except the empty string):
'match the dict.keys with validation list to determine the common ones (the rest are Errors)
arrIntersect = Application.IfError(Application.Match(dict.Keys, list, 0), "Err")
For i = 1 To UBound(arrIntersect) 'iterate between the matching array elements
If arrIntersect(i) = "Err" Then 'the elements not being found in the validation list:
'Debug.Print dict.Keys(i - 1): Stop 'uncomment to visually see what will be deleted...
A.Replace dict.Keys()(i - 1), "" 'delete the value from the respective Area range
End If
Next i
dict.RemoveAll 'prepare it for the next range Area
End If
Next A
End Sub
```
3. Copy the next (easily) adapted code in the "Fundfakt-kateg-vinkl" code module:
```
Option Explicit
Private Sub Worksheet_Activate()
AddNamedRangeAndSetDropDown True 'it recreates the validations according the the last changes in source sheets
'and clear the selection where not in the validation list, anymore
End Sub
Sub Worksheet_Change(ByVal Target As Range)
'limit the event to trigger ONLY THE NECESSARY DROPDOWN RANGES:
If Not Intersect(Target, Union(Me.Range(DropDownsRangeAddress), _
Me.Range(DropDownsRange2Address), Me.Range(DropDownsRange3Address))) Is Nothing Then
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Left(Target.Value, 1) = "*" And Right(Target.Value, 1) = "*" Then
MsgBox "You can't select a heading: '" & Target.Value + "'" & vbCr & vbCr & vbTab & "Try again. ", vbCritical
Application.EnableEvents = False
Application.Undo 'place back the value existing before change!
Application.EnableEvents = True
End If
End If
End Sub
```
It calls now the main function, but without recreating the Source ranges Names, because it is not necessary, anymore. They are of dynamic type and adapts by themself (using a formula).
4. Copy the next code in `ThisWorkbook` code module. It recreates **all named ranges** and validation ranges **when the workbook is opened**.
If something not clear, please do not hesitate to ask for clarifications.
Please, use the next solution:
1. Copy the code in a **standard module**:
```
Option Explicit
Public Const DropDownsSourceRangeName As String = "Angle"
Public Const DropDownsRangeName As String = "DropDownsRange"
Public Const DropDownsSourceSheetName As String = "Angles for estimation"
Public Const DropDownsSheetName As String = "Fundfakt-kateg-vinkl"
Public Const DropDownsSourceRangeAddress As String = "$A$8:$A$1008"
Public Const DropDownsRangeAddress As String = "$AC$4:$AI$18"
'declarations for the new part:
Public Const DropDownsSourceSheetName2 As String = "Categories for estimation"
Public Const DropDownsSourceSheetName3 As String = "Fundamentals for estimation"
Public Const DropDownsRangeName2 As String = "DropDownsRange1"
Public Const DropDownsRangeName3 As String = "DropDownsRange2"
Public Const DropDownsSourceRangeName2 As String = "Angle1"
Public Const DropDownsSourceRangeName3 As String = "Angle2"
Public Const DropDownsSourceRange2Address As String = "$A$8:$A$1008"
Public Const DropDownsSourceRange3Address As String = "$A$8:$A$22" 'source for Fundamentals...
Public Const DropDownsRange2Address As String = "$Q$4:$W$18"
Public Const DropDownsRange3Address As String = "$A$4:$G$18"
Sub AddNamedRangeAndSetDropDown()
DeleteNamedRanges
ThisWorkbook.Names.Add Name:=DropDownsSourceRangeName, RefersTo:="='" & DropDownsSourceSheetName & "'!" & DropDownsSourceRangeAddress 'Angle for estimation
ThisWorkbook.Names.Add Name:=DropDownsRangeName, RefersTo:="='" & DropDownsSheetName & "'!" & DropDownsRangeAddress 'where to place the DropDown based on above source
ThisWorkbook.Names.Add Name:=DropDownsSourceRangeName2, RefersTo:="='" & DropDownsSourceSheetName2 & "'!" & DropDownsSourceRange2Address 'Categories for estimation
ThisWorkbook.Names.Add Name:=DropDownsRangeName2, RefersTo:="='" & DropDownsSheetName & "'!" & DropDownsRange2Address 'where to place the DropDown based on above source
ThisWorkbook.Names.Add Name:=DropDownsSourceRangeName3, RefersTo:="='" & DropDownsSourceSheetName3 & "'!" & DropDownsSourceRange3Address 'Fundamentals for estimation
ThisWorkbook.Names.Add Name:=DropDownsRangeName3, RefersTo:="='" & DropDownsSheetName & "'!" & DropDownsRange3Address 'where to place the DropDown based on above source
SetDropDownList
End Sub
Sub DeleteNamedRanges()
On Error GoTo ErrorHandler
Dim i As Long
For i = ThisWorkbook.Names.Count To 1 Step -1
Select Case ThisWorkbook.Names(i).Name
Case DropDownsSourceRangeName, DropDownsRangeName, DropDownsSourceRangeName2, DropDownsRangeName2, DropDownsSourceRangeName3, DropDownsRangeName3
ThisWorkbook.Names(i).Delete
Case Else
If InStr(ThisWorkbook.Names(i).Name, DropDownsSourceRangeName) Or _
InStr(ThisWorkbook.Names(i).Name, DropDownsRangeName) Then _
If InStr(ThisWorkbook.Names(i).Name, DropDownsSourceRangeName2) Or _
InStr(ThisWorkbook.Names(i).Name, DropDownsRangeName2) Then _
If InStr(ThisWorkbook.Names(i).Name, DropDownsSourceRangeName3) Or _
InStr(ThisWorkbook.Names(i).Name, DropDownsRangeName3) Then _
ThisWorkbook.Names(i).Delete
End Select
Next i
Exit Sub
ErrorHandler:
MsgBox "An error occurred " & Err.Description
End Sub
Sub SetDropDownList() 'No need of any iteration. Validation can be add from all the range, at once!
Dim rngDropDown As Range, arrDrD(), arrSource(), arrAngle(), i As Long
arrDrD = Array(DropDownsRangeName, DropDownsRangeName2, DropDownsRangeName3)
arrSource = Array(DropDownsSourceRangeName, DropDownsSourceRangeName2, DropDownsSourceRangeName3)
arrAngle = Array("Angle", "Angle1", "Angle2")
For i = 0 To UBound(arrDrD)
Set rngDropDown = Sheets(DropDownsSheetName).Range(arrDrD(i))
With rngDropDown.Validation
.Delete 'clear existd Validation rules, if any
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=getFormula1(CStr(arrSource(i)))
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = vbNullString '"Select a value"
.ErrorTitle = "Invalid value"
.InputMessage = arrAngle(i)
.ErrorMessage = "Select a valid value in the list."
.ShowInput = True
.ShowError = True
End With
Next i
End Sub
Function getFormula1(drDownSourceName As String) As String
Const strStrange As String = "|#$%^"
Dim rng As Range, arr, arr1
Set rng = Range(drDownSourceName) 'set the range where from to extract the list (without blanck cells)
arr1 = rng.Value 'place the range in an array to finally drop its content back
rng.Replace "", strStrange, xlWhole 'replace the empty cells with strStrange
arr = Application.WorksheetFunction.Transpose(rng) 'place the range in a 1D array
arr = Filter(arr, strStrange, False) 'replace the former empty cells (strStrange array elements)
getFormula1 = Join(arr, ",")
rng.Value = arr1 'place back the original range content
End Function
```
a. It validates **without iteration between each ranges cell**, not being necessary.
b. `getFormula1` takes a parameter and it also **do not use iteration**.
2. Please, copy the next code event in sheet "Fundfakt-kateg-vinkl" code module:
```
Option Explicit
Private Sub Worksheet_Activate()
AddNamedRangeAndSetDropDown 'it recreates the validations according the the last changes in source sheets (when this sheet is activated)
End Sub
Sub Worksheet_Change(ByVal Target As Range)
'limit the event to trigger ONLY THE NECESSARY DROPDOWN RANGES:
If Not Intersect(Target, Union(Me.Range(DropDownsRangeAddress), _
Me.Range(DropDownsRange2Address), Me.Range(DropDownsRange3Address))) Is Nothing Then
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Left(Target.Value, 1) = "*" And Right(Target.Value, 1) = "*" Then
MsgBox "You can't select a heading: '" & Target.Value + "'" & vbCr & vbCr & vbTab & "Try again. ", vbCritical
Application.EnableEvents = False
'Target.Value = ""
Application.Undo 'place back the value existing before change!
Application.EnableEvents = True
End If
End If
End Sub
```
The code is not triggered by changing a cell **not intersecting with the three ranges which the above code processes**.
It also does need `BeforeCellChange` function. It searches inside the validation list, not in the range where it came from. It is enough to have the headers with "*" character as first and last character.
Please, send some feedback after testing it. I will send back the test working workbook, in a comment.
