Sortieren und löschen
26.08.2003 14:44:35
Silvi
Zur Info: Bin ziemlich unwissend in Sachen Makros und stell mich wahrscheinlich entsprechend blöd an. Hab schon Stunden mit der Recherche verbracht aber nix gefunden das zu meinem Problem paßt...
Also vielleicht kann mir ja jemand helfen.
Ich möchte eine Datei mit vielen vielen Formeln in eine neue Datei ohne Formeln kopieren. Dann möchte ich die Daten nach einer Spalte z.B. D sortieren, Zeilen mit Null löschen und diese Daten dann in zwei neue Tabellenblätter einfügen. Jetzt sollen in der Tabelle1 nur noch die Zeilen mit dem Suchkriterium "1" (aus Spalte D) stehen, in Tabelle1 (2) Zeilen mit "2", in Tabelle1 (3) Zeilen mit "3" stehen.
Die Datei mit den Formeln ist immer unterschiedlich groß und beinhaltet nicht immer Suchkriterium(3).
Unten stehndes habe ich mir zusammengebastelt (z.T. mit aufzeichnen) und funktioniert auch fast, bis auf wenn Suchkriterium (3) fehlt.
Is mir noch zu helfen?
Sub löschen()
Workbooks.Open FileName:="X:Daten.xls"
Windows("DateiMitFormeln.xls").Activate
Cells.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Rows("1:7").Select
Application.CutCopyMode = False
Selection.FormatConditions.Delete
Range("A8:AN10000").Select
Selection.Sort Key1:=Range("D8"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Dim a As Range
Range("d8:d10000").Select
For Each a In Selection
If IsNumeric(a) And Not IsEmpty(a) Then
If a.Value = 0 Then Range(Cells(8, 1), a).Select
End If
Next
Selection.EntireRow.Delete
Sheets("Tabelle1").Copy after:=Sheets(1)
Sheets("Tabelle1").Copy after:=Sheets(2)
Sheets("Tabelle1 (2)").Select
Dim b As Range
Range("d8:d10000").Select
For Each b In Selection
If IsNumeric(b) And Not IsEmpty(b) Then
If b.Value = 1 Then Range(Cells(8, 1), b).Select
End If
Next
Selection.EntireRow.Delete
Rows("8:10000").Select
Selection.Sort Key1:=Range("d8"), Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Dim f As Range
Range("d8:d10000").Select
For Each f In Selection
If IsNumeric(f) And Not IsEmpty(f) Then
If f.Value = 3 Then Range(Cells(8, 1), f).Select
End If
Next
Selection.EntireRow.Delete
Sheets("Tabelle1").Select
Rows("8:10000").Select
Selection.Sort Key1:=Range("d8"), Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Dim c As Range
Range("d8:d10000").Select
For Each c In Selection
If IsNumeric(c) And Not IsEmpty(c) Then
If c.Value = 2 Or c.Value = 3 Then Range(Cells(8, 1), c).Select
End If
Next
Selection.EntireRow.Delete
Sheets("Tabelle1 (3)").Select
Dim g As Range
Range("d8:d10000").Select
For Each g In Selection
If IsNumeric(g) And Not IsEmpty(g) Then
If g.Value = 1 Or g.Value = 2 Then Range(Cells(8, 1), g).Select
End If
Next
Selection.EntireRow.Delete
Sheets("Tabelle1 (2)").Name = "Bla"
Sheets("Tabelle1 (3)").Name = "Bla Bla"
Sheets("Tabelle1").Name = "Bla Bla Bla"
End Sub