Guten Tag Ramses, vielen Dank für Deine Nachfrage.
Der vollständige Code unten funktioniert ausser dem Löschen der Bilder!
Kannst Du mir den Fehler finden?
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,D83:D90,D101:D108,D119:D126,D137: _
D144,D155:D162,D173:D180,D191:D198,D208:D215,D225:D232,D242:D249,d259:d2662,d276:d283,d293:d300,d310:d317,d327:d334,d344:d351,d361:d368,d378:d385,d395:d402,d412:d419,d429:d436,d4446:d453]) Is Nothing Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 9)).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,L83:L90,L101:L108,L119:L126,L137: _
L144,L155:L162,L173:L180, L191:L198,L208:L215,L225:L232,L242:L249,L259:L266,L276:L283,L293:L300,L310:L317,L327:L334,L344:L351,L361:L368,L378:L385,L395:L402,L412:L419,L429:L436,L446:L453]) 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 (OK)
If Not Intersect(Target, [D6,D24,D42,D60,D78,D96,D114,D132,D150,D168,D187,L187, D204,L204, _
D221,L221,D238,L238,D255,L255,D272,L272,D289,L289,D306,L306,D323,L323,D340,L340,D357,L357,D374,L374,D391,L391,D408,L408,D425,L425,D442,L442]) Is Nothing Then
UserForm1_1.Show
End If
'Löschen des Bildes
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, [B202,B219,B236,B253,B270,B287,B304,B321,B338,B355,B372,B389,B406,B423, _
B440]) Is Nothing Then
Target.Resize(17, 1).EntireRow.Delete 'ab Zelle B202 oder B... wird der Bereich von 17 Zeilen _
gelöscht
lngMax = Application.Max(202, .Cells(Rows.Count, 1).End(xlUp).Row - 14)
lngMin = lngMax - 14
Set rng = Union(.Range(.Cells(lngMin, 4), .Cells(lngMax, 4)), _
.Range(.Cells(lngMin, -12), .Cells(lngMax, -12)))
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