Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target.Cells(1), Columns(2)) Is Nothing Then
Select Case Target.Offset(0, -1).MergeArea.Cells(1).Value
Case "Email Adresse", "Telefon"
Debug.Print TypeName(Target.Value)
If Target.Value <> "" Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Target.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Target.Copy
Target.Offset(1, 0).PasteSpecial xlPasteValidation
Target.Offset(1, 0).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Target.Offset(0, -1).MergeArea.Resize(Target.Offset(0, -1).MergeArea.Rows.Count + 1).Merge
Target.Offset(0, -1).MergeArea.Borders(xlEdgeBottom).LineStyle = Target.Offset(0, -1).MergeArea.Borders(xlEdgeTop).LineStyle
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Select
End If
End Sub