Hi Ihr,

Ich brauch da mal eure Hilfe. Folgender Code funktioniert zwar sehr gut, jedoch dauert es sehr lange, bis alle Schritte durchgeführt werden:

Option Explicit

Public Sub Ordnen()

    Sheets("kleine").Select
    Cells.Select
    Selection.ClearContents
    Sheets("mittlere").Select
    Cells.Select
    Selection.ClearContents
    Sheets("grosse").Select
    Cells.Select
    Selection.ClearContents

Dim i As Integer
Dim Zelle As Range
Dim leereZeile
Dim j As Long

For Each Zelle In Tabelle1.Range("B:B")

With Worksheets("kleine")
    j = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    If Not (j = 1 And .Cells(1, 1) = "") Then j = j + 1
End With
i = 1
'For Each Zelle In Tabelle1.Range("B:B")
    If Not Zelle Is Nothing Then
        If Zelle.Value = "<1" & ChrW(956) & "m" Then
            Zelle.EntireRow.Copy
            Worksheets("kleine").Cells(j, 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            j = j + 1
            i = i + 1
    End If
End If


With Worksheets("mittlere")
    j = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    If Not (j = 1 And .Cells(1, 1) = "") Then j = j + 1
End With
i = 1
    If Not Zelle Is Nothing Then
        If Zelle.Value = "1" & ChrW(956) & "m - 10" & ChrW(956) & "m" Then
            Zelle.EntireRow.Copy
            Worksheets("mittlere").Cells(j, 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            j = j + 1
            i = i + 1
    End If
End If

With Worksheets("grosse")
    j = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
    If Not (j = 1 And .Cells(1, 1) = "") Then j = j + 1
End With
i = 1
    If Not Zelle Is Nothing Then
        If Zelle.Value = ">10" & ChrW(956) & "m" Then
            Zelle.EntireRow.Copy
            Worksheets("grosse").Cells(j, 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            j = j + 1
            i = i + 1
    End If
End If


Next Zelle
    
    Sheets("kleine").Select
    Columns("D:E").Select
    Selection.Cut
    Columns("O:O").Select
    ActiveSheet.Paste
    Columns("D:E").Select
    Selection.Delete Shift:=xlToLeft
    
    Sheets("mittlere").Select
    Columns("D:E").Select
    Selection.Cut
    Columns("O:O").Select
    ActiveSheet.Paste
    Columns("D:E").Select
    Selection.Delete Shift:=xlToLeft
    
    Sheets("grosse").Select
    Columns("D:E").Select
    Selection.Cut
    Columns("O:O").Select
    ActiveSheet.Paste
    Columns("D:E").Select
    Selection.Delete Shift:=xlToLeft
    
    Sheets("kleine").Select
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Sheets("mittlere").Select
    Columns("B:B").Select
    Range("B4").Activate
    Selection.Delete Shift:=xlToLeft
    Sheets("grosse").Select
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    
    

End Sub



Hat jemand eine Ahnung woran das liegen und wie man das Problem beheben könnte???

Vielen Dank im Voraus.

MarkiMark