Hallo Reinhad, entschuldige bitte, dass ich erst jetzt antworte!
Vielen Dank für Deine Bemühungen.
Dim rng As Range wird im Code benötigt!
Das ganze sieht nun wie folgt aus und funktioniert.
mfg
Ernst Dunkel
Private Sub worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
'Doppelklick auf D11 bis D18 und D.. löscht Zellen D bis G
If Not Intersect(Target, [D11:D18,D29:D36,D47:D54,D65:D72,D82:D89,D99:D106,D116:D123,D133: _
D140,D150:D157,D167:D174,D184:D191,D201:D208,D218:D225,D235:D242]) Is Nothing Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 7)).ClearContents
Application.EnableEvents = True
End If
Cancel = True
'Doppelklick auf L11 bis L18 und L.. löscht Zellen D bis G
If Not Intersect(Target, [L11:L18,L29:L36,L47:L54,L65:L72,L82:L89,L99:L106,L116:L123,L133: _
L140,L150:L157,L167:L174,L184:L191,L201:L208,L218:L225,L235:L242]) Is Nothing Then
Application.EnableEvents = False
Range(Cells(Target.Row, 12), Cells(Target.Row, 15)).ClearContents
Application.EnableEvents = True
End If
Cancel = True
'Doppelklick auf D6,D24, D42 L7 und D10,D24 wir die UF1 geöffnet
If Not Intersect(Target, [D6,D24,D42,D61,L61,D78,L78, D95, L95, D112,L112,D129,L129,D146, _
L146,D163,L163,D180,L180,D197,L197,D214,L214,D231,L231,D248,L248]) Is Nothing Then
UserForm1_1.Show
End If
'aber hier neu
Dim objShp As Shape
Dim rng As Range
Dim lngMax As Long, lngMin As Long
Application.ScreenUpdating = False
With Worksheets("U-Value")
.Unprotect ("^~`")
If Not Intersect(Target, [B23,B41,B59,B77,B95,B113,B131,B149,B167,B185]) Is Nothing Then
Target.Resize(18, 1).EntireRow.Delete
For Each objShp In .Shapes
If Left(objShp.Name, 3) = "pic" Then
If Not Intersect(rng, objShp.TopLeftCell) Is Nothing Then
objShp.Delete
End If
End If
Next
Application.ScreenUpdating = True
Worksheets("U-Value").Protect ("^~`")
End If
End With
End Sub