Office: (Office 365) Zeilen löschen wenn eine Zelle der Zeile einen bestimmten Inhalt hat

Hallo,
ich brauche mal wieder eure Hilfe. Für die beschriebene Aufgabe benutze ich folgenden Code der soweit auch gut funktioniert:


Code:

Sub ZeileLöschen()
Dim Bereich As Range
Dim Zelle As Range
Dim WegMit As Range
Set Bereich = Intersect(Range("B:B"), ActiveSheet.UsedRange)
For Each Zelle In Bereich
If Zelle Like "*Handcreme*" Or Zelle Like "Haftcreme*" Or Zelle Like "*Stokoderm*" Then
If WegMit Is Nothing Then
Set WegMit = Zelle
Else
Set WegMit = Union(WegMit, Zelle)
End If
End If
Next Zelle
If Not WegMit Is Nothing Then WegMit.EntireRow.Delete
End Sub

Ist es möglich, den Range nicht nur auf eine Spalte zu setzen (hier Spalte B) sondern z.B. B:H? Nur den "Set Bereich" zu ändern führt bei mir zu folgender Fehlermeldung:
"Bei überlappenden Markierungen ist die Auführung dieses Befehls nicht möglich" Laufzeitfehler 1004" Der Fehler tritt im rot markierten Bereich auf.
Vielen Dank für eure HIlfe.
Alexander

 

Hallo,

Du beschränkst im Intersect den Bereich auf Spalte B und den Used Range. Warum?
Eigentlich sollte doch das reichen: Set Bereich =Range("B:H")

 

Hallo Alexander,
hat Dein Code nichrt einen Fehler?
WegMit
wird nicht gesetzt.

 

Hallo Alexander,

ich hätte die Aufgabe so interpretiert?

Code:

Option Explicit

Sub ZeileLöschen()
    Dim Bereich As Range
    Dim Zelle As Range
    'Dim WegMit As Range
    Set Bereich = Intersect(Range("B:B,H:H"), ActiveSheet.UsedRange)
    For Each Zelle In Bereich
        If Zelle Like "*Handcreme*" Then
            Zelle = Application.Substitute(Zelle, "Handcreme", "")
        ElseIf Zelle Like "Haftcreme*" Then
            Zelle = Application.Substitute(Zelle, "Haftcreme", "")
        ElseIf Zelle Like "*Stokoderm*" Then
            Zelle = Application.Substitute(Zelle, "Stokoderm", "")
'            If WegMit Is Nothing Then
'                Set WegMit = Zelle
'            Else
'                Set WegMit = Union(WegMit, Zelle)
'            End If
        End If
    Next Zelle
    Set Zelle = Nothing
'    If Not WegMit Is Nothing Then WegMit.EntireRow.Delete
End Sub

Gruß Hajo

 

Danke für die Antworten.

@BoskoBiati: So funktioniert es, hat nur ne sehr lange Laufzeit (so ca. 60 Sekunden, deshalb die Beschränkung auf den benutzten Bereich)

@Hajo_Zi: Danke Hajo, leider passiert mit diesem Code so wie er dasteht nichts. Es sollen nicht nur die Zellen gelöscht werden in den der Ausdruck vorkommt sondern die gesamte Zeile der Zelle in der der Ausdruck gefunden wurde.

 

jetzt bekomme ich bei der Abänderung des Codes den gleichen Fehler. Kann es sein, dass es ein Problem gibt, wenn des zu suchende Ausdruck in mehreren Zellen in derselben Zeile vorkommt?

 

das stand nicht im ersten Beitrag. Ich scjaue nicht auf Deinen Rechner und kann damit die Datei nicht sehen
Rows(Zelle.Row).Delete

Gruß Hajo

 

Hallo,

welche Aufgabe soll Dein Makro denn erfüllen?
Warum begrenzt Du den Bereich nicht auf die gefüllten Zeilen?
Stelle doch bitte mal eine Mustertabelle vor.

 

Hallo,
hier die Mustertabelle. Z.B. kommt der Ausdruck nach dem gesucht werden soll "Rezeptur" einmal in der Spalte F oder in Spalte H oder in beiden vor. Unabhängig vom Fundort des gesuchten Ausdrucks soll die Zeile gelöscht werden, in der der Ausdruck gefunden wurde.
Ich hoffe, ich konnte es einigermaßen verständlich beschreiben

 

Hallo,

anhand Deiner Mustertabelle:

Code:

Sub Loeschen()
Dim rng As Range
Dim loLetzte As Long
Dim loA As Long, loC As Long, loB As Long
Dim arrSuch As Variant
loLetzte = Cells(Rows.Count, 1).End(xlUp).Row
For loA = loLetzte To 3 Step -1
 For loC = 1 To 10
    If Cells(loA, loC) Like ("*Rezeptur*") Then loB = 1
Next
If loB = 1 Then Rows(loA).EntireRow.Delete
loB = 0
Next
End Sub

 

Hallo Edgar,
funktioniert prima. Kann man auch nach mehrerenAusdrücken suchen?

Danke
Alexander

 

Hi,

z.B. so:

Code:

Sub Loeschen()
Dim loLetzte As Long
Dim loA As Long, loC As Long, loB As Long
loLetzte = Cells(Rows.Count, 1).End(xlUp).Row
For loA = loLetzte To 3 Step -1
 For loC = 1 To 10
    If Cells(loA, loC) Like ("*Rezeptur*") or Cells(loA, loC) Like ("*Hallo*") Then loB = 1
Next
If loB = 1 Then Rows(loA).EntireRow.Delete
loB = 0
Next
End Sub

 

Hi,

hier noch eine Variante, die vielleicht schneller ist:

Code:

Sub Loeschen_2()
Dim arrSuch
Dim loLetzte As Long, loA&, loB&, loC&
Dim rng As Range
loLetzte = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range(Cells(3, 1), Cells(loLetzte, 8))
arrSuch = rng.Value
For loA = UBound(arrSuch, 1) To LBound(arrSuch, 1) Step -1
    For loB = LBound(arrSuch, 2) To UBound(arrSuch, 2)
        If InStr(1, arrSuch(loA, loB), "Rezeptur") > 0 or InStr(1, arrSuch(loA, loB), "Apotheke") > 0 Then loC = 1
    Next
    If loC = 1 Then Rows(loA + 2).EntireRow.Delete
    loC = 0
Next
arrSuch = ""

End Sub

 

Hi,

wenn es schnell sein soll, dann benutzt man Excel-Funktionalitäten hier insbesondere "Duplikate entfernen"

Code:

Sub löschen()
Dim Bereich As Range
Dim s As String
s = "=SUM(COUNTIF(RC2:RC8,{""*Rezeptur*"";""*Haftcreme*"";""*Stokoderm*""}))>0"
Set Bereich = ActiveSheet.UsedRange
Set Bereich = Bereich.Offset(, Bereich.Columns.Count).Resize(, 1)
Bereich.FormulaR1C1 = s
Bereich.Cells(1) = True
Bereich.Copy
Bereich.PasteSpecial xlPasteValues
ActiveSheet.UsedRange.RemoveDuplicates Columns:=Bereich.Column, Header:=xlNo
Bereich.Clear
End Sub