Hallo Martha,

es kann nur unter der Bedingung, dass tmp einen Datensatz zurückgibt dieser Fehler auftreten. Ansonsten ist es egal wie viele verschiedene Lager es in Spalte A gibt.

Der mögliche Fehler ist also nur ein Datensatz für das eine Lager.

Änderungen so:

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
        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)
            If n > 1 Then 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
            If n > 1 Then
                .Cells(lz, 1).Resize(UBound(tmp, 1), UBound(tmp, 2)) = tmp
            Else
                Cells(lz, 1).Resize(1, UBound(tmp) - LBound(tmp) + 1) = tmp
            End If
            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

Gruß Uwe