bestimmte Daten löschen auto.

Hallo alle zusammen,
ich habe folgendes Makro:
Range("A1").Select
Selection.ClearContents
Range("B1").Select
Selection.ClearContents
Range("A3:B4").Select
Selection.ClearContents
Range("A6:B7").Select
Selection.ClearContents
Range("A9:B9").Select
Selection.ClearContents
Range("A11").Select
Selection.ClearContents
Range("I12:CS43").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=33
Range("F46:M67").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=21
Range("A69:F108").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=54
Range("A112:D135").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-138
Das funktioniert soweit auch gut, nur möchte ich das bei Range I:12 schon ab Spalte A Zeile 13 , er automatisch die ganze Zeile 13 durchgeht und erst dann löscht , wenn in der Zeile das Wort End steht und ebenso bei F:46, Spalte A Zeile 47 er löscht, wenn kein Inhalt drinnen ist in Zeile 47.
Danke für eure Hilfe!
GlG

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Unit() Range("A1:B1,A3:B4,A6:B7,A9:B9,A11:A11,A69:F108,A112:D135").ClearContents If WorksheetFunction.CountIf(Rows(13), "End") > 0 Then Range("I12:CS43").ClearContents End If If WorksheetFunction.CountBlank(Rows(47)) = Columns.Count Then Range("F46:M67").ClearContents End If End Sub

Sub Unit() Dim col As Range Dim del_rng As Range 'Range("A1:B1,A3:B4,A6:B7,A9:B9,A11:A11,A69:F108,A112:D135").ClearContents Set col = Rows(13).Find("End") If Not col Is Nothing Then Set del_rng = Range(col, col.End(xlToRight)) del_rng.Select 'del_rng.ClearContents End If If Range("F47") = "" Then Range("F47:M67").ClearContents End Sub

Das sollte klappen...
Den ersten Berich hab ich noch erweitert (die letzten beiden Terme)


Sub Unit()
Dim col As Range
Dim del_rng As Range, del_rng2 As Range
Dim löschbereich As Range
On Error Resume Next
Set löschbereich = Range("A1:B1,A3:B4,A6:B7,A9:B9,A11:A11,A69:G135")
Set col = Rows(13).Find("End")
If Not col Is Nothing Then
Set del_rng = Range(col, col.End(xlToRight)) 'bis zum letzten "END"
Set del_rng = del_rng.Offset(-1, 0).Resize(32, del_rng.Columns.Count) 'Bereich verschieben + vergrößern
End If
Set col = Rows(47).SpecialCells(xlBlanks) 'leere Zellen in Reihe 47
Set del_rng2 = col.Offset(-1, 0).Resize(22, col.Columns.Count) 'Bereich verschieben + vergrößern
löschbereich.ClearContents
del_rng.ClearContents
del_rng2.ClearContents
'oder
'    Set löschbereich = Application.Union(löschbereich, del_rng, del_rng2) Bereiche vereinen
'löschbereich.ClearContents
Set col = Nothing
Set del_rng = Nothing
Set del_rng2 = Nothing
Set löschbereich = Nothing
End Sub

Gruß, MCO

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread