Public Sub OpenExcel()
    Dim XL As Excel.Application
    Dim ActiveWkb As Workbook
    Dim i As Integer
    Dim x As Integer
    Dim arrRow() As String
    Dim OneLine As New SingleLine
    Dim NextLine As New SingleLine
    Dim comp As String
    Dim comp2 As String
    Dim u As Integer
    Dim count As Integer
    Dim addRow As Long   
 
        'Open a new Chart
        Set XL = CreateObject("Excel.Application")
        'XL.Visible = True
 
        XL.Application.Workbooks.Add
        Set ActiveWkb = XL.Application.ActiveWorkbook
 
        count = 1
        With ActiveWkb
 
                u = 1
 
            Application.ScreenUpdating = False
 
            For i = 2 To List.count    'List ist eine Collection, die 
            ' SingleLine's als Elemente hat
 
                DoEvents
                Set OneLine = New SingleLine
                Set NextLine = New SingleLine
                Set OneLine = List.Item(i - 1)
                Set NextLine = List.Item(i)
                arrRow = OneLine.Get_row()
                comp = OneLine.Get_key()
                comp2 = NextLine.Get_key()
 
 
                .Worksheets(u).Name = comp
                .Worksheets(u).Range("A" & count, "M" & count) = arrRow
 
                If (comp2 = comp) Then
 
                    count = count + 1
 
                Else
 
                    If (u >= 3) Then
 
                        .Worksheets.Add After:=.Worksheets(.Worksheets.count)
 
                    End If
 
                    count = 1
                    u = u + 1
 
                End If
 
            Next i
 
            For i = 1 To .Worksheets.count
 
                .Worksheets(i).Activate
                .Worksheets(i).Cells.AutoFilter
                .Worksheets(i).Cells.EntireColumn.AutoFit
               [u] .Worksheets(i).Range("A1").Sort Key1:=Worksheets( _
                 i).Columns("A")
                   'Hier tritt der Fehler beim zweiten Durchlauf auf
            Next i
 
            For i = 1 To .Worksheets.count
 
                .Worksheets(i).Activate
                addRow = .Worksheets(i).UsedRange.Rows.count
                .Worksheets(i).Cells((addRow + 3), 1) = "Sheet " & i & " of " & _
                  .Worksheets.count
 
            Next i
 
            Application.ScreenUpdating = True           'show result
 
            .Worksheets(1).Activate
 
        End With
 
        XL.Application.Calculate
        XL.Visible = True
 
        Set ActiveWkb = Nothing
 
End Sub