Bereich löschen

Private Sub worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim objShp As Shape Dim rng As Range On Error Resume Next If Not Intersect(Target, [B23,B41,B59,B77,B95,B113,B131,B149,B167,B185]) Is Nothing Then Application.ScreenUpdating = False With Worksheets("U-Value") Mit Doppelklick auf B23, B41, etc., werden jeweils 18 Zeilen darunter gelöscht. Randbedingung: nur bis zur Zeile 23 und max. bis zur Zeile 201 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 End With Application.ScreenUpdating = True End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Private Sub worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim objShp As Shape Dim rng As Range On Error Resume Next If Intersect(Target, [B23,B41,B59,B77,B95,B113,B131,B149,B167,B185]) Is Nothing Then Exit Sub Application.ScreenUpdating = False With Worksheets("U-Value") 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 Target.Offset(1, 0).Resize(18, 1).EntireRow.Delete End With Application.ScreenUpdating = True End Sub

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

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bereich löschen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread