Bereich löschen

Forumthread: Bereich löschen

Bereich löschen

Ernst

Hallo Forum
Benötige Eure Hilfe!
Möchte mit Doppelklick auf Zelle B23, B41, etc., jeweils 18 Zeilen darunter löschen.
Randbedingung: nur bis zur Zeile 23 und max. bis zur Zeile 201
Könnte mir jemand bei der Ergänzung im untenstehenden Code behilflich sein?
mfg
Ernst Dunkel

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

AW: Bereich löschen

01.03.2010 13:09:47

Rudi

Hallo,
die Bedingung hast du ja schon geschaffen.
Target.Resize(19).EntireRow.Delete
rng ist NOTHING.
Gruß
Rudi

AW: Bereich löschen

01.03.2010 22:04:54

Ernst

Hallo Ruedi
Vielen Dank für Deine Rückmeldung.
Es ist nicht ganz das was ich möchte!
Mit doppelklick z.B. auf B23 soll ein Berecih (Range) von 18 Zeilen unter halb der aktuellen Zeile gelöscht werden.
Bitte um Hilfe
mfg
Ernst Dunkel

AW: Bereich löschen

02.03.2010 08:32:36

Reinhard

Hallo Ernst,
was ist nun mit "rng"?

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

Gruß
Reinhard

AW: Bereich löschen

02.03.2010 23:13:30

Ernst

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

möglich daß es funktioniert, ...

03.03.2010 09:36:52

Reinhard

Hallo Ernst,
... aber "rng" taucht nur zweimal im Code auf:
Dim rng As Range
und
If Not Intersect(rng, objShp.TopLeftCell) Is Nothing Then
Also wird das If nie ausgeführt weil nie True.
Gruß
REinhard

Beliebteste Forumthreads (12 Monate)

Forumthread: Bereich löschen

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread