Public Sub OpenExcel()
    Dim XL As Object
    Dim ActiveWkb As Object
    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
 
        'On Error GoTo FailOpenExcel
 
        'Open Chart
        Set XL = CreateObject("Excel.Application")
 
        XL.Application.Workbooks.Add
        Set ActiveWkb = XL.Application.ActiveWorkbook
 
        count = 1
        u = 1
        With ActiveWkb
 
            For i = 2 To List.count
                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()
 
                If (comp2 = comp) Then         'Vergleichen der keys
 
                    For x = 0 To (UBound(arrRow))
 
                        .Worksheets(u).Cells(count, (x + 1)) = arrRow(x) _
                            'eine Zeile füllen
                        'Fehler:'Subscript out of range'
 
                     Next
                    count = count + 1
                Else
                    u = u + 1
                    count = 1
                End If
 
            Next i
 
        End With
 
        XL.Application.Calculate
        XL.Visible = True
 
FailOpenExcel:
    If (Err.Number <> 0) Then
        MsgBox Err.Description, vbMsgBoxHelpButton, "Fehler", Err.HelpFile, _
          Err.HelpContext
    End If
 
    Set ActiveWkb = Nothing
 
End Sub