Microsoft Excel

Herbers Excel/VBA-Archiv

Sortieren und löschen

    Betrifft: Sortieren und löschen von: Silvi
    Geschrieben am: 26.08.2003 14:44:35

    Hallo zusammen!
    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
    

      


    Betrifft: AW: Sortieren und löschen von: Lothar
    Geschrieben am: 26.08.2003 15:34:14

    Hi Silvi,

    was soll denn mit den Zeilen passieren, wo das Suchkriterium fehlt ?
    - ganz raus
    - zu 1
    - zu 2

    ???
    Gruss
    Lothar


      


    Betrifft: AW: Sortieren und löschen von: Silvi
    Geschrieben am: 26.08.2003 15:43:05

    Hallo Lothar
    ganz raus, d.h. wenn Daten vorhanden dann in Tabelle1 (3) sonst leer.

    Danke!

    Gruß
    Silvi


      


    Betrifft: AW: Sortieren und löschen von: Lothar
    Geschrieben am: 26.08.2003 17:15:32

    So Silvi, das sollte gehen.
    Die Tabelle1 könnte danach gelöscht werden. (das kriegst Du wohl selbst hin).
    Achtung: Die Blätter K0 bis K3 werden namentlich erzeugt. Bevor Du das Macro ein 2. mal ausführst, müssen diese Blätter gelöscht werden, da ich eine Fehlerroutine sparen wollte. :-)

    Gruss
    Lothar


    Option Explicit
    Sub NachKritAufteilen()
    Dim i, j As Integer
    Application.ScreenUpdating = False
    j = 0
    For i = 0 To 3
    Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = "K" & j
        j = j + 1
    Next
    Sheets(1).Select
       With Range("A1")
          .AutoFilter Field:=4, Criteria1:="0" 'Field muss ggf. jeweils angepasst werden
          .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
             Worksheets("K0").Range("A1")
          .AutoFilter Field:=4, Criteria1:="1"
          .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
             Worksheets("K1").Range("A1")
          .AutoFilter Field:=4, Criteria1:="2"
          .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
             Worksheets("K2").Range("A1")
          .AutoFilter Field:=4, Criteria1:="3"
          .CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
             Worksheets("K3").Range("A1")
       End With
    ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
        
    End Sub
    



     

    Beiträge aus den Excel-Beispielen zum Thema " Sortieren und löschen"