VBA erweitern: Zeilen löschen

Sub Filter() Application.ScreenUpdating = False Dim iRow As Single Dim i As Single Range("A1", Range("a65536").End(xlUp)).Select iRow = ActiveSheet.UsedRange.Rows.Count 'Auswahl Anfangszelle Cells(2, 2).Select For i = iRow To 2 Step -1 If Cells(i, 2).Value "Text1" Then Cells(i, 1).EntireRow.Delete End If Next i Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Filter() Application.ScreenUpdating = False Dim iRow As Single Dim i As Single Range("A1", Range("a65536").End(xlUp)).Select iRow = ActiveSheet.UsedRange.Rows.Count 'Auswahl Anfangszelle Cells(2, 2).Select For i = iRow To 2 Step -1 If Cells(i, 2).Value "Text1" Or "Text4" Or "Text7" Or "Text9" Then Cells(i, 1).EntireRow.Delete End If Next i Application.ScreenUpdating = True End Sub

Public Sub Löschen() Dim loLetzte As Long, i As Long Application.ScreenUpdating = False With Worksheets("Tabelle1") 'Blattname anpassen loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row For i = loLetzte To 2 Step -1 Select Case .Cells(i, 2).Value Case "Text1", "Text2", "Text3", "Text4" 'nix machen Case Else Rows(i).Delete End Select Next i End With Application.ScreenUpdating = True End Sub

Sub test() Dim t As Double Call szenario t = Timer Call Löschen_Mit_Schleife Debug.Print "Schleife: "; Timer - t, Call szenario t = Timer Call Löschen_Mit_REMOVEDUPLICATES Debug.Print "RemDupl:"; Timer - t End Sub Sub szenario() Cells.Clear With Cells(1, 1).Resize(100000, 3) .Columns(1).Value = "xxx" .Columns(2).Formula = "=""Text""&Mod(Row(),8)+1" .Columns(2).Formula = .Columns(2).Value .Columns(3).Value = "xxx" End With End Sub Public Sub Löschen_Mit_Schleife() Dim loLetzte As Long, i As Long Application.ScreenUpdating = False With ActiveSheet 'Blattname anpassen loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row For i = loLetzte To 2 Step -1 Select Case .Cells(i, 2).Value Case "Text1", "Text2", "Text3", "Text4" 'nix machen Case Else Rows(i).Delete End Select Next i End With Application.ScreenUpdating = True End Sub Sub Löschen_Mit_REMOVEDUPLICATES() With ActiveSheet.Cells(1, 1).CurrentRegion With .Columns(.Columns.Count + 1) .FormulaR1C1 = "=IF(IsNumber(Find(""|""&RC2&""|"",""|Text1|Text2|Text3|Text4|"")),Row(),0)" .Cells(1, 1).Value = 0 .EntireRow.RemoveDuplicates .Column, xlNo .ClearContents End With End With End Sub

Hallo Daniel,
zu deinen Fragen:
- ca.500 Spalten
- über 100.000 Zeilen
- es gibt keine Formeln in der Datei
- Daten sollen reduziert werden: a) Zeilen => mehrere Kriterien für zwei Spalten und b) Spaltenüberschriften => mehrere Kriterien
Anbei der Code:


Sub Reduzierung()
If ActiveWorkbook.Name = ThisWorkbook.Name Then
MsgBox "Makro aus der zu der bearbeitenden Datei starten"
Exit Sub
End If
' 10 Kriterien in Spalte B bleiben, andere 5 Kriterien werden gelöscht, max. Zeichenlänge = 7
Dim loLetzte As Long, i As Long
Application.ScreenUpdating = False
With ActiveSheet
loLetzte = .Cells(.Rows.Count, 2).End(xlUp).Row
For i = loLetzte To 2 Step -1
Select Case .Cells(i, 2).Value
Case "AO", "U", "DA", "DJ", "F", "GAB", "WW", "Z", "JK", "KY"
Case Else
Rows(i).Delete
End Select
Next i
End With
Application.ScreenUpdating = True
' 18 Kriterien in Spalte T bleiben, andere 25 Kriterien werden gelöscht, max. Zeichenlänge = 20
Dim lz As Long, j As Long
Application.ScreenUpdating = False
With ActiveSheet
lz = .Cells(.Rows.Count, 20).End(xlUp).Row
For j = lz To 2 Step -1
Select Case .Cells(j, 20).Value
Case "11111X", "22 222Y", "3 3X", "XXXXY", "AAAA 3", "22 AA BB", "A()1_XXXX1", "A+B  _
111111_X", "YX1", "WS 56", "XX 11 YYYYY", "XX 22222-66-8", "(1)  1111  AA- (2)2", "2222", "22 22 YX(1)", "3333X", "XX 2-2 Y", "000_X"
Case Else
Rows(j).Delete
End Select
Next j
End With
Application.ScreenUpdating = True
' 50 Spaltenüberschriften bleiben, andere 450 Spalten werden gelöscht, max. Zeichenlänge der Ü _
berschriften = 20
Dim SpZ As Long
Dim TABELLENNAME As String
Application.ScreenUpdating = False
SpZ = Cells(1, Columns.Count).End(xlToLeft).Column
For SpZ = SpZ To 1 Step -1
TABELLENNAME = Cells(1, SpZ)
If TABELLENNAME  "Überschrift  [1]" And TABELLENNAME  " Überschrift  [2]" And  _
TABELLENNAME  " Überschrift  [3]" And TABELLENNAME  " Überschrift  [4]" And TABELLENNAME  " Überschrift  [5]" And TABELLENNAME  " Überschrift  [6]" And TABELLENNAME  " Überschrift  [7]" And TABELLENNAME  " Überschrift  [8]" And TABELLENNAME  " Überschrift  [9]" And TABELLENNAME  " Überschrift  [10]" And TABELLENNAME  " Überschrift  [11]" And TABELLENNAME  " Überschrift  [12]" And TABELLENNAME  " Überschrift  [13]" And TABELLENNAME  " Überschrift  [14]" And TABELLENNAME  " Überschrift  [15]" And TABELLENNAME  " Überschrift  [16]" And TABELLENNAME  " Überschrift  [17]" And TABELLENNAME  " Überschrift  [18]" And TABELLENNAME  " Überschrift  [19]" And TABELLENNAME  " Überschrift  [20]" And TABELLENNAME  " Überschrift  [21]" And TABELLENNAME  " Überschrift  [22]" And TABELLENNAME  " Überschrift  [23]" And TABELLENNAME  " Überschrift  [24]" And TABELLENNAME  " Überschrift  [25]" And TABELLENNAME  " Überschrift  [26]" And TABELLENNAME  " Überschrift  [27]" And TABELLENNAME  " Überschrift  [28]" And TABELLENNAME  " Überschrift  [29]" And TABELLENNAME  " Überschrift  [30]" And TABELLENNAME  " Überschrift  [31]" And TABELLENNAME  " Überschrift  [32]" And TABELLENNAME  " Überschrift  [33]" And TABELLENNAME  " Überschrift  [34]" And TABELLENNAME  " Überschrift  [35]" And TABELLENNAME  " Überschrift  [36]" And TABELLENNAME  " Überschrift  [37]" And TABELLENNAME  " Überschrift  [38]" And TABELLENNAME  " Überschrift  [39]" And TABELLENNAME  " Überschrift  [40]" And TABELLENNAME  " Überschrift  [41]" And TABELLENNAME  " Überschrift  [42]" And TABELLENNAME  " Überschrift  [43]" And TABELLENNAME  " Überschrift  [44]" And TABELLENNAME  " Überschrift  [45]" And TABELLENNAME  " Überschrift  [46]" And TABELLENNAME  " Überschrift  [47]" And TABELLENNAME  " Überschrift  [48]" And TABELLENNAME  " Überschrift  [49]" And TABELLENNAME  " Überschrift  [50]" Then
Columns(SpZ).Delete
End If
Next SpZ
Application.ScreenUpdating = True
' Alle Daten als Tabelle formatieren
ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.UsedRange, , xlYes).Name = "Table1"
' Überschriften ergänzen
Range("AE1") = " Überschrift  [51]"
Range("AF1") = " Überschrift  [52]"
' Gruppe (als Wert) eintragen
Range("Table1[Gruppe]").Formula = "A.10"
' Jahr (als Wert) eintragen
Range("Table1[Jahr]").Formula = "2015"
Application.ScreenUpdating = True
End Sub

Den Code wollte ich eigentlich noch zusätzlich um diese zwei Operationen ergänzen:


Sub Zusatz()
' Spalte durch 1000 teilen
Application.ScreenUpdating = False
Range("Table1[Überschrift  [50]]").Select
Dim zelle As Range
For Each zelle In Selection
zelle.Value = zelle.Value / 1000
Next
' Erstelldatum der geöffneten Datei
Range("Table1[Überschrift  [49]]").Formula = CreateObject("Scripting.FileSystemObject"). _
GetFile(ThisWorkbook.FullName).DateCreated
Application.ScreenUpdating = True
End Sub

.. aber da bekomme ich leider eine Fehlermeldung, dass kein Speicher da ist. Mein Code ist wohl jetzt schon zu lang.
Ich hoffe, es ist alles verständlich ?

Sub Makro1() Application.ScreenUpdating = False With ActiveSheet.UsedRange With .Columns(.Columns.Count + 1) .FormulaR1C1 = "=IF(IsNumber(Find(""|""&RC2&""|"",""|AO|U|DA|DJ|F|GAB|WW|Z|JK|KY|"")),Row(),0)" .Cells(1, 1).Value = 0 .EntireRow.RemoveDuplicates .Column, xlNo .ClearContents End With End With Application.ScreenUpdating = True End Sub

Hi
das würde ich so machen:
1. liste die 50 Spaltenüberschriften, die erhalten bleiben müssen, in einem weitern Tabellenblatt in einer freien Spalte (z. B. Tabelle2!A:A) untereinander auf.
in einem Tabellenblatt hast du bei 50 verschiedenen Texten eine besser übersicht, als wenn du das im Code verdatest
2. um die Spalten zu identifizieren, verwendest du in der letzten Zeile eine Formel in dieser Art in der ersten freien Zeile unterhalb der Tabelle und löschst dann alle Spalten mit Fehler.
sieht dann in etwas so aus:

With ActiveSheet.Usedrange
With .Rows(.Rows.Count + 1)
.FormulaR1C1 = "=Match(R1C,Tabelle2!C1,0)"
.SpecialCells(xlcelltypeformulas, 16).EntireColumn.Delete
.ClearContents
end with
end with

probier auch mal, obs was bringt, wenn du erst die Spalten löschst und danach die Zeilen.
Gruß Daniel

Dim i As Long, j As Long SpZ = Cells(1, Columns.Count).End(xlToLeft).Column j = SpZ + 2 Application.ScreenUpdating = False For i = 1 To SpZ Select Case Cells(1, i).Value Case "Überschrift [1]", "Überschrift [2]", "Überschrift [3]", "Überschrift [4]" _ , "Überschrift [5]", "Überschrift [6]", "Überschrift [7]", "Überschrift [8]" _ , "Überschrift [9]", "Überschrift [10]", "Überschrift [11]", "Überschrift [12]" _ , "Überschrift [13]", "Überschrift [14]", "Überschrift [15]", "Überschrift [16]" _ , "Überschrift [17]", "Überschrift [18]", "Überschrift [19]", "Überschrift [20]" _ , "Überschrift [21]", "Überschrift [22]", "Überschrift [23]", "Überschrift [24]" _ , "Überschrift [25]", "Überschrift [26]", "Überschrift [27]", "Überschrift [28]" _ , "Überschrift [29]", "Überschrift [30]", "Überschrift [31]", "Überschrift [32]" _ , "Überschrift [33]", "Überschrift [34]", "Überschrift [35]", "Überschrift [36]" _ , "Überschrift [37]", "Überschrift [38]", "Überschrift [39]", "Überschrift [40]" _ , "Überschrift [41]", "Überschrift [42]", "Überschrift [43]", "Überschrift [44]" _ , "Überschrift [45]", "Überschrift [46]", "Überschrift [47]", "Überschrift [48]" _ , "Überschrift [49]", "Überschrift [50]" Columns(i).Copy Columns(j) j = j + 1 Case Else End Select Next i Range(Columns(1), Columns(SpZ + 1)).Delete Application.ScreenUpdating = True

Sheets.Add(before:=ActiveSheet).Name = "Ueberschriften" ActiveCell.FormulaR1C1 = "ÜB1" ActiveCell.FormulaR1C1 = "ÜB2" ActiveCell.FormulaR1C1 = "ÜB3" ActiveCell.FormulaR1C1 = "ÜB4" ActiveCell.FormulaR1C1 = "ÜB5" ActiveCell.FormulaR1C1 = "ÜB6"

Sub SpaltenEntfernen() Dim spaltenzaehler As Integer Dim Name As String Application.ScreenUpdating = False spaltenzaehler = 1 While Cells(1, spaltenzaehler) "" Name = Cells(1, spaltenzaehler) If Name "Text1" And Name "Text2" And Name "Text3" And Name "Text4" Then Columns(spaltenzaehler).Delete spaltenzaehler = spaltenzaehler - 1 End If spaltenzaehler = spaltenzaehler + 1 Wend Application.ScreenUpdating = True End Sub

Sub ZeilenEntfernen() Dim zeilenzaehler As Integer Dim Name As String Application.ScreenUpdating = False zeilenzaehler = 2 While Cells(zeilenzaehler, 2) "" Name = Cells(zeilenzaehler, 2) If Name "1" And Name "2" And Name "3" And Name "4" Then Rows(zeilenzaehler).Delete zeilenzaehler = zeilenzaehler - 1 End If zeilenzaehler = zeilenzaehler + 1 Wend Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

36
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

332 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA erweitern: Zeilen löschen

36 Beiträge zum Forumthread Beiträge zu diesem Forumthread

332 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

36
Beiträge zum Forumthread

Beiträge zu diesem Forumthread