AW: Makro zum Zeilenlöschen - Frage
27.08.2007 23:41:02
fcs
Hallo Nils,
das Makro funktioniert mit der Datei einwandfrei, außer dass es wegen der großen Zeilenzahl sehr lange benötigt. Die von dir beschriebenen Fehler konnte ich nicht feststellen.
Ich hab das Makro geringfügig angepasst, so dass die Bildschirmaktualisierung während der Makro-Aktionen deaktiviert ist und Makro schneller läuft. Zusätzlich wird in der Statuszeile der Fortschritt der Bearbeitung angezeigt.
Ich hab auch eine Variante gebastelt, die die Tabelle zunächst sortiert (Sortierung ist nicht notwendig, wenn die Daten immer nach dem Feld "f54s_bumo" sortiert von der Queryabfrage geliefert werden!).
Danach werden die 1. und letzte Zeile mit Eintrag "106" ermittelt und zum Schluss die zu löschenden Zeilen blockweise gelöscht. So dauert die ganze Makroausführung höchstens 1 bis 2 Sekunden.
Als kleines Goody wird zum Schluß das als Dezimalzahl geschriebene Datum in Spalte 3 in das Excelinterne Datumsformat umgewandelt. Diese Funktion kannst du ja wieder löschen, wenn du sie nicht brauchst.
Gruß
Franz
Sub aTest()
Dim wks As Worksheet, wb As Workbook, spalte As Integer, wert As Variant, Zeile As Long
Dim Zaehler As Long, Zeilen As Long
spalte = 4 ' zu prüfende Spalte
wert = 106 'prüfwert
'Aktives Blatt Kopieren
ActiveSheet.Copy
Set wb = ActiveWorkbook
Set wks = wb.Worksheets(1)
Application.ScreenUpdating = False
Zaehler = 1
With wks
'Daten ab letzter Zeile rückwärts prüfen und ggf. Zeile löschen
Zeilen = .Cells.SpecialCells(xlCellTypeLastCell).Row
For Zeile = Zeilen To 2 Step -1
Application.StatusBar = "Bearbeite Zeile " & Zaehler & " von " & Zeilen
If .Cells(Zeile, spalte).Value wert Then
.Rows(Zeile).Delete Shift:=xlShiftUp
End If
Zaehler = Zaehler + 1
Next
End With
Application.StatusBar = False
Application.ScreenUpdating = True
'Speichern unter Dialog anzeigen
Application.Dialogs(xlDialogSaveAs).Show "TestDatei.xls"
End Sub
'Variante
Sub bTest()
Dim wks As Worksheet, wb As Workbook, spalte As Integer, wert As Variant, Zeile As Long
Dim Zeilen As Long, Zelle1 As Range, Zelle2 As Range
spalte = 4 ' zu prüfende Spalte
wert = 106 'prüfwert
'Aktives Blatt Kopieren
ActiveSheet.Copy
Set wb = ActiveWorkbook
Set wks = wb.Worksheets(1)
Application.ScreenUpdating = False
Zaehler = 1
With wks
'letzte Zeile mit Daten
Zeilen = .Cells.SpecialCells(xlCellTypeLastCell).Row
'Daten nach Spalte D sortieren
.Range(.Cells(1, 1), .Cells(Zeilen, 5)).Sort Key1:=.Cells(1, spalte), _
order1:=xlAscending, header:=xlYes
'1. Zeile mit Wert suchen
Set Zelle1 = .Columns(spalte).Find(What:=wert, after:=.Cells(1, spalte), _
LookIn:=xlValues, Lookat:=xlWhole, Searchdirection:=xlNext)
'Letzte Zeile mit Wert suchen
Set Zelle2 = .Columns(spalte).Find(What:=wert, after:=.Cells(Zeilen + 1, spalte), _
LookIn:=xlValues, Lookat:=xlWhole, Searchdirection:=xlPrevious)
'Daten prüfen und ggf. Zeilen löschen
If Zelle1 Is Nothing Then
MsgBox "Wert " & wert & " wurde in Tabelle nicht gefunden!"
Else
Select Case Zelle1.Row
Case 2
If Zelle2.Row