Hallo Martha,

teste mal, ob das deinen Vorstellungen entspricht.

Option Explicit
    Private Const Startzeile& = 2

Sub ListeSortieren()
    Dim i&, j&, k&, n&, lz&, objSL As Object, arrLager(), arrTab(), tmp()
    Set objSL = CreateObject("System.Collections.SortedList")  'MS NET Framwork 3.5 ist erforderlich - ggf. nachinstallieren
    With Tabelle1   ' Modulname des Tabellenblattes
        arrTab = .UsedRange.Offset(1, 0).Value
        arrLager = .Range(.Cells(Startzeile, 1), .Cells(Rows.Count, 1).End(xlUp)).Value
        For i = 1 To UBound(arrLager)
            If arrLager(i, 1) <> "" Then objSL(arrLager(i, 1)) = ""
        Next
        ReDim arrLager(1 To objSL.Count, 1 To 1)
        For i = 1 To objSL.Count
            arrLager(i, 1) = objSL.GetKey(i - 1)
        Next
        If .Cells(Rows.Count, 1).End(xlUp).Row >= Startzeile Then
            .Range(.Cells(Startzeile, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 11)).ClearContents
        End If
        For i = 1 To UBound(arrLager)
            For j = 1 To UBound(arrTab)
                If arrLager(i, 1) = arrTab(j, 1) Then
                    n = n + 1
                    ReDim Preserve tmp(1 To UBound(arrTab, 2), 1 To n)
                    For k = 1 To UBound(arrTab, 2)
                        tmp(k, n) = arrTab(j, k)
                    Next k
                End If
            Next j
            tmp = Application.Transpose(tmp)
            Call QuickSort(LBound(tmp), UBound(tmp), tmp, 5) 'Treffer sortieren via Spalte E
            If .Cells(Startzeile, 1) <> "" Then
                lz = .Cells(Rows.Count, 1).End(xlUp).Row + 3
            Else
                lz = Startzeile
            End If
            .Cells(lz, 1).Resize(UBound(tmp, 1), UBound(tmp, 2)) = tmp
            Erase tmp
            n = 0
        Next i
    End With
End Sub

Private Sub QuickSort(lngLBound As Long, lngUBound As Long, avntArray As Variant, lngSortColumn As Long)
    Dim lngIndex1 As Long, lngIndex2 As Long, lngColumn As Long
    Dim vntBuffer As Variant, vntTemp As Variant
    lngIndex1 = lngLBound
    lngIndex2 = lngUBound
    vntTemp = avntArray((lngLBound + lngUBound) \ 2, lngSortColumn)
    Do
        Do While avntArray(lngIndex1, lngSortColumn) < vntTemp
            lngIndex1 = lngIndex1 + 1
        Loop
        Do While vntTemp < avntArray(lngIndex2, lngSortColumn)
            lngIndex2 = lngIndex2 - 1
        Loop
        If lngIndex1 <= lngIndex2 Then
            For lngColumn = LBound(avntArray, 2) To UBound(avntArray, 2)
                vntBuffer = avntArray(lngIndex1, lngColumn)
                avntArray(lngIndex1, lngColumn) = avntArray(lngIndex2, lngColumn)
                avntArray(lngIndex2, lngColumn) = vntBuffer
            Next
            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1
        End If
    Loop Until lngIndex1 > lngIndex2
    If lngLBound < lngIndex2 Then Call QuickSort(lngLBound, lngIndex2, avntArray, lngSortColumn)
    If lngIndex1 < lngUBound Then Call QuickSort(lngIndex1, lngUBound, avntArray, lngSortColumn)
End Sub

Einen einfacheren Weg mit blockweisen Sortieren kann ich grad nicht erkennen.

Gruß Uwe