Please, try the next function:
Function isMergeEmpty(rng As Range) As Boolean
Dim x As String
On Error Resume Next
x = rng.value
If err.Number <> 0 Then
isMergeEmpty = True
End If
On Error GoTo 0
End Function
It can be called from the event in this way:
Private Sub Worksheet_Change(ByVal Target As Range)
If isMergeEmpty(Target) Then
'do here what you need...
MsgBox "Empty merge cell..."
End if
End Sub
Edited:
Please, test the next full solution:
Private Sub Worksheet_Change(ByVal Target As range)
Dim myList As Object
Set myList = CreateObject("Scripting.Dictionary")
myList.Add "Einseitig", 1
myList.Add "Doppelseitig", 2
myList.Add "Halbzylinder", 3
Dim lengthFromCell As range
Dim lengthToCell As range
' only execute when on column F and no more of one cell (IF Target is NOT merged):
If Target.Column <> 6 Or (Target.Cells.Count > 1 And Target.MergeCells = False) Then Exit Sub
Set lengthFromCell = Target.Offset(0, 1)
Set lengthToCell = lengthFromCell.Offset(1, 0)
Application.EnableEvents = False 'to avoid the event running three times
'it will also be triggered for each of the following lines:
' Delete contents of "length" cells
lengthFromCell.value = ""
lengthToCell.value = ""
If isMergeEmpty(Target) Then 'it should be first, in order to avoid `Target.value` which returns an error for an empty merged range
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="0, 0, 0"
.IgnoreBlank = True
.InCellDropdown = True
.ErrorTitle = "Werte ausserhalb Bereich"
.ErrorMessage = "Einseitig bla blub"
.ShowError = True
End With
ElseIf Target.value = "Einseitig" Then
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="1, 2, 3"
.IgnoreBlank = True
.InCellDropdown = True
.ErrorTitle = "Werte ausserhalb Bereich"
.ErrorMessage = "Einseitig bla blub"
.ShowError = True
End With
ElseIf Target.value = "Doppelseitig" Then
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="4, 5, 6"
.IgnoreBlank = True
.InCellDropdown = True
.ErrorTitle = "Werte ausserhalb Bereich"
.ErrorMessage = "Einseitig bla blub"
.ShowError = True
End With
ElseIf Target.value = "Halbzylinder" Then
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="7, 8, 9"
.IgnoreBlank = True
.InCellDropdown = True
.ErrorTitle = "Werte ausserhalb Bereich"
.ErrorMessage = "Einseitig bla blub"
.ShowError = True
End With
End If
Application.EnableEvents = True
End Sub
Function isMergeEmpty(rng As range) As Boolean
Dim x As String
On Error Resume Next
x = rng.value
If Err.Number <> 0 Then
isMergeEmpty = True
End If
On Error GoTo 0
End Function
Now, the main problem of our code as it was consisted in the way it was exited, in case of more then one cell. VBA has a peculiar behavior when treats a merged range having a value and *an empty such merged range, in terms of Cells.Count property. You must know that TargetCells.Count returns 1 if it refers a merged range having a value and **the number of cells in the mergeArea if it is empty. That's why the need to add Or (Target.Cells.Count > 1 And Target.MergeCells = False). To exclude from exiting cases of empty merged Target. Your code, as it was, exited on this line and the supplied function was never called.
Then, in order to avoid Target.Value = ..., which returns an error in case of an empty merged Target the checking for an empty Target must be first.
I also optimized the code in order to avoid the event to be triggered three times, instead of one.
If something still unclear, please do not hesitate to ask for clarifications. I alo commented the specific lines inside the code...
Second Edit:
I thought that you created an unmerged example only to show the different behavior against the merged one. But if you need the code to also work in such a case, another condition must be add at the end. Then, the code cam become more compact as the next one:
Private Sub Worksheet_Change(ByVal Target As range)
Dim myList As Object: Set myList = CreateObject("Scripting.Dictionary")
myList.Add "Einseitig", 1: myList.Add "Doppelseitig", 2: myList.Add "Halbzylinder", 3
Dim lengthFromCell As range, lengthToCell As range, strFormula As String
' only execute when on column F and Target.CellsCount =1 (excluding the merged Target):
If Target.Column <> 6 Or (Target.Cells.Count > 1 And Target.MergeCells = False) Then Exit Sub
Set lengthFromCell = Target.Offset(0, 1): Set lengthToCell = lengthFromCell.Offset(1, 0)
Application.EnableEvents = False
' Delete contents of "length" cells
lengthFromCell.value = "": lengthToCell.value = ""
If isMergeEmpty(Target) Then
strFormula = "0, 0, 0"
ElseIf Target.value = "Einseitig" Then
strFormula = "1, 2, 3"
ElseIf Target.value = "Doppelseitig" Then
strFormula = "4, 5, 6"
ElseIf Target.value = "Halbzylinder" Then
strFormula = "7, 8, 9"
ElseIf Target.value = "" Then 'for the case of not merged Target:
strFormula = "0, 0, 0"
End If
If strFormula <> "" Then
With Target.Offset(0, 1).Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:=strFormula
.IgnoreBlank = True
.InCellDropdown = True
.ErrorTitle = "Werte ausserhalb Bereich"
.ErrorMessage = "Einseitig bla blub"
.ShowError = True
End With
End If
Application.EnableEvents = True
End Sub
