Thema: Löschen funktioniert nicht | Herbers Excel-Forum

Hallo,
möchte alle DS löschen (ab Zeile 3) , die in Spalte X kein "Auto" stehen haben.
Dim i
For i = 1 To 100
If Cells(i, 24).Value <> "Auto" Then _
Cells(i, 1).EntireRow.Delete
Next i
Problem 1: irgend wie funktioniert der Code nicht richtig, er löscht immer nur die untersten und ich muss ein paar mal die Funktion ausführen ehe alle weg sind.
Problem 2: in den Zeilen, die gelöscht werden sollen, sind teilweise Grafiken eingefügt. Wird eine Zeile gelöscht, bleibt die Grafik dazu stehen.
Gibt es noch einen anderen Lösch -Befehl ?
Danke für Eure Hilfe
Kai

Hallo Kai
Zu 1)
Wie Petra schon geschrieben hat:

Sub tt()
Dim i As Integer
For i = 100 to 1
If Cells(i, 24) <> "Auto" Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End Sub

Zeilen immer von unten nach oben löschen. Warum?
Angenommen in X20 und X21 steht "Auto".
Bei Deinem Code löscht er dann die Zeile 20. Somit wird Zeile 21 zu Zeile 20. Die Variable i wird aber nach dem löschen um 1 erhöht (ist dann also 21). Somit wird die jetzige Zeile 20 zum Löschen übersprungen.
Zu 2)
Wie sind die Grafiken denn eingebunden? Von Zellgröße und -position abhängig?
Dann kann man über die TopLeft-Eigenschaft die Grafik löschen.
Lad doch mal die Mappe hoch. Dann kann man das darauf anpassen.
Gruß aus dem Sauerland
Jens

Hallo Jens,
ich lade meine Grafiken so:
If ActiveSheet.Cells(i, 6).Value = "Bild" Then
Range("G3").Select
Sheets("Grafiken").Select
ActiveSheet.Shapes("Picture 18").Select
Selection.Copy
Sheets("Daten").Select
Cells(i, 8).Select
ActiveSheet.Paste
End If
Also im Prinzip einfach per copy / paste. Die Grafiken liegen auf einem anderen Tabellenblatt.
Gruss
Kai

Hallo Kai
Lad mal bitte die Datei mit ein paar Beispieldaten hoch.
Gruß Jens

Hier eine Beispieldatei:
https://www.herber.de/bbs/user/66058.xls
Gruss

Hallo,
versuche es mal so.

Sub LoscheGrafig()
Dim oShab As Shape, i As Integer
Dim meAr() As String
With Tabelle2
    
    For Each oShab In .Shapes
     If oShab.BottomRightCell.Column = 8 Then
       If oShab.Type = msoPicture Then
        Redim Preserve meAr(i)
        meAr(i) = oShab.Name
        i = i + 1
       End If
     End If
    Next oShab
    
    If i > 0 Then .Shapes.Range(meAr).Delete
End With
End Sub

Sub Grafik_laden()
Dim i&
Call LoscheGrafig
With Tabelle2
For i = 1 To 500
    If .Cells(i, 6).Value = "green" Then
        Sheets("Tabelle2").Shapes("Picture 19").Copy
        .Cells(i, 8).PasteSpecial
    End If
Next i
End With
End Sub

Sub Loeschen_Mit_Formel()
Dim oSH As Worksheet, iCalc As Integer
Dim strSuchwert As String


strSuchwert = "Auto"

Set oSH = Tabelle2 'Tabelle anpassen 

With Application
 iCalc = .Calculation
 .Calculation = xlCalculationManual
 .ScreenUpdating = False
 
     With oSH.UsedRange
        With .Columns(.Columns.Count).Offset(0, 1)
            
            .Formula = "=IF(RC2<>""" & strSuchwert & """,True,ROW())" 'entsprechende Formel 
            
             oSH.UsedRange.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
            
            On Error Resume Next
             .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
             .EntireColumn.Delete
            On Error GoTo 0
        End With
     End With
  Call Grafik_laden
 .ScreenUpdating = True
 .Calculation = iCalc
End With

End Sub

Gruß Tino

Hallo,
im ersten Beitrag schreibst Du, dass Du Auto in Spalte 24 suchst.
mach aus der Zeile
.Formula = "=IF(RC2<>""" & strSuchwert & """,True,ROW())" 'entsprechende Formel
diese
.Formula = "=IF(RC24<>""" & strSuchwert & """,True,ROW())" 'entsprechende Formel
Gruß Tino