In VBA ein (Order by )

Sub CopyUniqueToSheets()
    Dim ws As Worksheet, newWS As Worksheet, cell As Range, dic As Object, c As Range
    'Dictionary-Objekt erzeugen  
    Set dic = CreateObject("Scripting.Dictionary")  
    'Worksheet festlegen in dem die Daten liegen  
    Set ws = Sheets(1)
    'letze Zeile ermitteln  
    lastRow = ws.UsedRange.Rows.Count
    
    For Each cell In ws.Range("L2:L" & lastRow)  
        'Wenn das Land in der aktuellen Zelle noch nicht verarbeitet wurde  
        If Not dic.Exists(cell.Value) Then
            'Land zum Dictionary hinzufügen  
            dic.Add cell.Value, ""  
            'neues Worksheet hinzufügen  
            Set newWS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            'dem Worksheet den Namen des Landes geben  
            newWS.Name = cell.Value
            'Überschriftenzeile übertragen  
            ws.Range("A1").EntireRow.Copy newWS.Range("A1")  
            'Suche in Spalte L  
            With ws.Range(cell, "L" & lastRow)  
                'Suche das Land in der aktuellen Zelle  
                Set c = .Find(cell.Value, LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        'Eintrag gefunden, kopiere die gefundene Zeile ins neue Sheet ans Ende  
                        c.EntireRow.Copy newWS.UsedRange.Cells(newWS.UsedRange.Rows.Count + 1, 1)
                        'Suche den nächsten Eintrag  
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
            End With
        End If
    Next
End Sub

Sub CopyUniqueToNewWorkbooks()
    Dim ws As Worksheet, newWS As Worksheet, cell As Range, dic As Object, c As Range, wb As Workbook, savePath As String
    'Dictionary-Objekt erzeugen  
    Set dic = CreateObject("Scripting.Dictionary")  
    'Pfad festlegen in dem die neuen Mappen gespeichert werden  
    savePath = ActiveWorkbook.Path
    'Worksheet festlegen in dem die Daten liegen  
    Set ws = Sheets(1)
    'letze Zeile ermitteln  
    lastRow = ws.UsedRange.Rows.Count
    
    For Each cell In ws.Range("L2:L" & lastRow)  
        'Wenn das Land in der aktuellen Zelle noch nicht verarbeitet wurde  
        If Not dic.Exists(cell.Value) Then
            'Land zum Dictionary hinzufügen  
            dic.Add cell.Value, ""  
            'neues Workbook hinzufügen  
            Set wb = Workbooks.Add
            'neues Worksheet setzen  
            Set newWS = wb.Worksheets(1)
            'dem Worksheet den Namen des Landes geben  
            newWS.Name = cell.Value
            'Überschriftenzeile übertragen  
            ws.Range("A1").EntireRow.Copy newWS.Range("A1")  
            'Suche in Spalte L  
            With ws.Range(cell, "L" & lastRow)  
                'Suche das Land in der aktuellen Zelle  
                Set c = .Find(cell.Value, LookIn:=xlValues)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        'Eintrag gefunden, kopiere die gefundene Zeile ins neue Sheet ans Ende  
                        c.EntireRow.Copy newWS.UsedRange.Cells(newWS.UsedRange.Rows.Count + 1, 1)
                        'Suche den nächsten Eintrag  
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
            End With
            'neu erstelltes Workbook im selben Verzeichnis speichern  
            wb.SaveAs savePath & "\" & cell.Value  
        End If
    Next
End Sub

Sub AlternativeWithOriginalTableSort()
    Dim ws As Worksheet, newWS As Worksheet, cell As Range, dic As Object, curCell As Range, activeWS As Worksheet
    'Worksheet festlegen in dem die Daten liegen  
    Set ws = Sheets(1)
    Set curCell = ws.Range("L2")  
    ws.UsedRange.Sort curCell, xlAscending, Header:=xlYes
    While curCell <> ""  
        If curCell.Value <> curCell.Offset(-1, 0) Then
            'neues Worksheet hinzufügen  
            Set activeWS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            'dem Worksheet den Namen des Landes geben  
            activeWS.Name = curCell.Value
            'Überschriftenzeile übertragen  
            ws.Range("A1").EntireRow.Copy activeWS.Range("A1")  
            'Daten der aktuellen Zeile kopieren  
            curCell.EntireRow.Copy activeWS.UsedRange.Cells(activeWS.UsedRange.Rows.Count + 1, 1)
        Else
            'Daten der aktuellen Zeile kopieren  
            curCell.EntireRow.Copy activeWS.UsedRange.Cells(activeWS.UsedRange.Rows.Count + 1, 1)
        End If
        'nächste Zeile setzen  
        Set curCell = curCell.Offset(1, 0)
    Wend
End Sub