suchen, Treffer-Zeilen löschen

Sub mat_abw() Dim Treffer Do Set Treffer = Range(ActiveSheet.UsedRange.Address).Find("Ergebnis") If Not Treffer Is Nothing Then Zeile = Treffer.Row Rows(Zeile).EntireRow.Delete End If Loop Until Treffer Is Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
hier zwei Varianten.
1. Für eine Spalte, im Beispiel Spalte B
für eine andere Spalte die Zeile mit der Formel anpassen.
.Formula = "=IF(RC2=""" & strSuchwert & """,True,ROW())" 'entsprechende Formel
2. Für ganze Tabelle
In beiden Fällen muss eine freie Spalte zur Verfügung stehen. (1. neben UsedRange)
In beiden habe ich eine Zeitmessung eingebaut zum testen.
kommt als Code in Modul1

Option Explicit 
 
Sub Loeschen_Mit_Formel() 
Dim oSH As Worksheet, iCalc As Integer 
Dim sTimer As Single 
Dim strSuchwert As String 
 
sTimer = Timer 'zum Zeitmessen 
 
strSuchwert = "Ergebnis" 
 
Set oSH = Sheets("Tabelle1") '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 
            On Error GoTo 0 
             
            .EntireColumn.Delete 
        End With 
     End With 
  
 .ScreenUpdating = True 
 .Calculation = iCalc 
End With 
 
MsgBox "fertig nach: " & Timer - sTimer & " Sekunden" 
End Sub

kommt als Code in Modul2

Option Explicit 
 
Sub Makro1() 
Dim meAr(), tmpAr() 
Dim A As Long, AA As Long 
Dim oSH As Worksheet 
Dim strSuchwert As String 
Dim sTimer As Single 
Dim iCalc As Integer 
 
sTimer = Timer 'zum Zeitmessen 
strSuchwert = "Ergebnis" 
 
Set oSH = Sheets("Tabelle1") 
 
If Application.WorksheetFunction.CountIf(oSH.Cells, strSuchwert) > 0 Then 
   With Application 
        iCalc = .Calculation 
        .ScreenUpdating = False 
        .Calculation = xlCalculationManual 
               With oSH.UsedRange 
                     
                    meAr = .Value2 
                    Redim Preserve tmpAr(1 To Ubound(meAr)) 
                     
                    For A = 1 To Ubound(meAr) 
                        For AA = 1 To Ubound(meAr, 2) 
                            If CStr(meAr(A, AA)) = strSuchwert Then 
                                tmpAr(A) = "=TRUE" 
                            ElseIf tmpAr(A) <> "=TRUE" Then 
                                tmpAr(A) = "=ROW()" 
                            End If 
                        Next AA 
                    Next A 
                     
                    With .Columns(.Columns.Count).Offset(0, 1) 
                         
                        .Cells(1, 1).Resize(A).FormulaR1C1 = Application.Transpose(tmpAr) 
                        oSH.UsedRange.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo 
                        On Error Resume Next 
                        .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete 
                        On Error GoTo 0 
                        .EntireColumn.Delete 
                        
                    End With 
                 
                End With 'oSH.UsedRange 
         .ScreenUpdating = True 
         .Calculation = iCalc 
    End With 'Application 
End If 
 
MsgBox "fertig nach: " & Timer - sTimer & " Sekunden" 
End Sub

Gruß Tino

Hallo Tino,
ich weiß nicht, wie das funktioniert, aber dein Code ist im Gegensatz zu meinen ca. 200s innerhalb einer (!!!!!) Sekunde fertig.
Erich muss sich leider mit dem dritten Platz (763s) begnügen. ;-)
(ich vermute, da der "Union"-Bereich mit jedem Durchlauf immer größer wird, bremst das den Code mit der Zeit immer mehr. Die ersten paar Tausend Zeilen gehen noch recht zügig, aber ab ca. 4-5 Tausend wirds immer "zäher", soviel haben ein paar kleine Tests ergeben)
@Tino:
Ich habe allerdings das Problem, dass ich deinen Code nicht ganz verstehe, somit momentan leider nicht als Wissens-Gewinn für mich verbuchen kann.
Vielleicht kannst du noch ein paar Kommentare dazu geben? Folgende Zeilen interessieren mich besonders (darin die fett gekennzeichneten Ausdrücke):
Redim Preserve tmpAr(1 To Ubound(meAr))
For A = 1 To Ubound(meAr)
.Cells(1, 1).Resize(A).FormulaR1C1 = Application.Transpose(tmpAr)
Danke schon mal.
Damit vermeide ich Irritationen bei den zukünftigen Anwender, die durch die lange Laufzeit wahrscheinlich entstanden wären.
Gruß
David

Sub Makro1() Dim meAr(), tmpAr() Dim A As Long, AA As Long Dim oSH As Worksheet Dim strSuchwert As String Dim sTimer As Single Dim iCalc As Integer sTimer = Timer 'zum Zeitmessen 'Dein Suchwert strSuchwert = "Ergebnis" Set oSH = Sheets("Tabelle1") 'gibt es im Usedrange den Suchwert? If Application.WorksheetFunction.CountIf(oSH.Cells, strSuchwert) > 0 Then With Application iCalc = .Calculation .ScreenUpdating = False .Calculation = xlCalculationManual With oSH.UsedRange 'Array aus Datenbereich erstellen meAr = .Value2 'größe des Hilfs Array festlegen Redim Preserve tmpAr(1 To Ubound(meAr)) 'Schleife über alle Daten im Aray For A = 1 To Ubound(meAr) 'erst Formel für Zeile einfügen tmpAr(A) = "=ROW()" For AA = 1 To Ubound(meAr, 2) If CStr(meAr(A, AA)) = strSuchwert Then tmpAr(A) = "=TRUE" 'Formel für Trefferzeile Exit For 'gefunden kann Schleife verlassen werden End If Next AA Next A 'Spalte neben UsedRange With .Columns(.Columns.Count).Offset(0, 1) 'Hilfsspalte mit der Formel aus Hilfsarray füllen, Transpose = Array drehen .Cells(1, 1).Resize(A).FormulaR1C1 = Application.Transpose(tmpAr) 'nach Hilfsspalte Sortieren oSH.UsedRange.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo On Error Resume Next 'alle Zeilen mit dem Ergebnis Wahr löschen .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete On Error GoTo 0 'Hilfsspalte löschen .EntireColumn.Delete End With End With 'oSH.UsedRange .ScreenUpdating = True .Calculation = iCalc End With 'Application End If MsgBox "fertig nach: " & Timer - sTimer & " Sekunden" End Sub

Option Explicit ' IMMER ZU EMPFEHLEN ! Sub mat_abw2() Dim rngF As Range, lngFirst As Long, rngDel As Range With ActiveSheet.UsedRange Set rngF = .Find(What:="Ergebnis", After:=.Cells(.Rows.Count, .Columns.Count), _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If Not rngF Is Nothing Then lngFirst = rngF.Row ' Zeile des 1. Treffers Do If rngDel Is Nothing Then Set rngDel = rngF Else Set rngDel = Union(rngDel, rngF) End If Set rngF = .FindNext(Cells(rngF.Row, .Column + .Columns.Count - 1)) Loop While rngF.Row > lngFirst rngDel.EntireRow.Delete ' hier wird gelöscht End If End With End Sub Sub TextIstZahl() Dim lngZ As Long, lngS As Long lngZ = 2 ' untersuchte Zeile For lngS = 1 To 20 ' Schleife über Spalten If IsNumeric(Cells(lngZ, lngS)) And Application.IsText(Cells(lngZ, lngS)) Then MsgBox "Spalte " & lngC & " bearbeiten" End If Next lngS End Sub

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

suchen, Treffer-Zeilen löschen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread