Filtercode langsam

Sub Ausblenden() Dim Zelle As Range Dim Bereich As Range Cells.EntireRow.Hidden = False For Each Zelle In Range(Cells(5, 1), Cells(4, 1).End(xlDown)) If WorksheetFunction.CountIf(Zelle.Offset(0, 1).Resize(, 2), Range("C1").Value) = 0 Then If Bereich Is Nothing Then Set Bereich = Zelle Else Set Bereich = Union(Bereich, Zelle) End If End If Next If Not Bereich Is Nothing Then Bereich.EntireRow.Hidden = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Danke. Das hat den Suchlauf zumindest von 30 auf 10 Sekunden reduziert.
Was ich nicht ganz verstehe: Es gibt eine weitere, ähnliche, Datei für letztes Jahr. Wenn ich dort den Code implementiere, dann findet er die Werte plötzlich nicht mehr. Sie ist leicht anders aufgebaut und die zu durchsuchenden Spalten befinden sich in J und L. Also habe ich folgende Änderung vorgenommen:

If WorksheetFunction.CountIf(Zelle.Offset(0, 10).Resize(, 3), Range("E1").Value) = 0 Then

Aber das geht irgendwie nicht. Es kommt die MsgBox, dass kein Suchergebnis gefunden wurde.
In der anderen Tabelle konnte ich auch einfach auf

If WorksheetFunction.CountIf(Zelle.Offset(0, 14).Resize(, 4), Range("E1").Value) = 0 Then

ändern, da die Daten in den Spalten O und R stehen. Das funktioniert.
Ist doch korrekt oder?

With wks HS = 50 'Hilfsspalte für Markierung 'alle Zeilen einblenden .Rows.Hidden = False 'Suchbegriff merken .Columns(HS).ClearContents varSuch = .Range("E1").Value For Each Zelle In .Range(.Cells(6, 1), .Cells(4, 1).End(xlDown)) If WorksheetFunction.CountIf(Intersect(Zelle.EntireRow, Range("J:L")), varSuch) > 0 _ Then .Cells(Zelle.Row, HS) = "X" End If Next varSuch = .Cells(4, 1).End(xlDown).Row With .Range(.Cells(6, HS), .Cells(varSuch, HS)) If Application.WorksheetFunction.CountIf(.Cells, "X") > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True Else MsgBox "Suchwert nicht gefunden!" End If End With End With

With wks HS = 50 'Hilfsspalte für Markierung 'alle Zeilen einblenden .Rows.Hidden = False 'Suchbegriff merken .Columns(HS).ClearContents varSuch = .Range("E1").Value letzteZeile = .Cells(5, 10).end(xldown) For Each Zelle In .Range(.Cells(6, 1), .Cells(letzteZeile, 1)) If WorksheetFunction.CountIf(Intersect(Zelle.EntireRow, Range("J:L")), varSuch) > 0 _ _ Then .Cells(Zelle.Row, HS) = "X" End If Next With .Range(.Cells(6, HS), .Cells(letzeZeile, HS)) If Application.WorksheetFunction.CountIf(.Cells, "X") > 0 Then .SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True Else MsgBox "Suchwert nicht gefunden!" End If End With End With

Hallo Anja,
hier eine Variante, die bei mehreren 1000 Datenzeilen nochmals um den faktor 2 bis 3 schneller sein sollte. Die zu durchsuchenden Daten werden dabei in ein Daten-Array geladen. Dadurch reduziert sich die
Anzahl der zeitfressenden Zugriffe auf Zellen im Tabellenblatt.
Den Hinweis von Daniel bzgl. letzte Datenzeile hab ich auch berücksichtigt, aber eine andere Methode verwendet, bei der keine Spalte vorgegben werden muss.
Gruß
Franz

Sub Ausblenden_via_Array()
Dim varSuch As Variant
Dim HS As Long
Dim Zelle As Range
Dim Bereich As Range
Dim wks As Worksheet
Dim Zeile As Long, Zeile_L As Long, Zeile_1 As Long
Dim StatusCalc As Long
Dim arrSuche, Spa As Long
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set wks = ActiveSheet
With wks
HS = 50                 'Hilfsspalte für Markierung
Zeile_1 = 6             '1. zu durchsuchende Zeile
'alle Zeilen einblenden
.Rows.Hidden = False
'alte Suchmarkierungen löschen
.Columns(HS).ClearContents
'Suchbegriff merken - alles in Kleinbuchstaben
varSuch = LCase(.Range("E1").Value)
'letzte Zeile mit Inhalt suchen
Set Zelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If Zelle Is Nothing Then
Zeile_L = 1
MsgBox "Tabellenblatt ist leer"
GoTo Beenden
Else
Zeile_L = Zelle.Row
End If
If Zeile_L  0 Then
.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
Else
MsgBox "Suchwert nicht gefunden!"
End If
End With
End With
Beenden:
'Makrobremsen zurüksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
End Sub

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