Excel VBA Sortierung von Daten

Sub Test()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim Sortierspalte As String, Bereich As String, wsList As Worksheet, wsData As Worksheet, strExportPath As String, strFilename As String, fso As Object, intColumn As Integer

Rows("1:12").Select  
Selection.Delete Shift:=xlUp

Columns("J:O").Select  
Selection.Delete Shift:=xlToLeft

Bereich = "A:Z"  
Sortierspalte = "H"  
ActiveSheet.Range(Bereich).Sort _
Key1:=Range(Sortierspalte & "1"), Order1:=xlAscending, _  
Header:=xlGuess, MatchCase:=False, _
Orientation:=xlTopToBottom

Columns("H:H").Copy  
Sheets.Add.Name = "Data"  
Sheets("Data").Paste  
Application.CutCopyMode = False
ActiveCell.EntireRow.Insert
ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlYes  


'Sheets festlegen  
Set wsList = Sheets("Data")  
Set wsData = Sheets("Sheet1")  

'Exportpfad für die Dateien  
strExportPath = "C:\Users\UserX\Desktop\Test\"  

'Objekte  
Set fso = CreateObject("Scripting.FileSystemObject")  

With wsList
    For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
        'Wenn Name in der Liste noch nicht bearbeitet wurde ...  
        If cell.Value <> "" And cell.Offset(0, 1).Value = "" Then  
            With wsData
                'AutoFilter zurücksetzen  
                .UsedRange.AutoFilter
                
                'Lege Suchspalte fest je nachdem ob es eine Kundennummer(Numerisch) ist oder nicht (Name)  
                intColumn = IIf(IsNumeric(cell.Value), 3, 1)
                
                ' Nur wenn Daten des Users vorhanden  
                If Not (.Columns(intColumn).Find(cell.Value)) Is Nothing Then
                    'Filtere die Datentabelle anhand des Namens/Kundennummer  
                    .UsedRange.AutoFilter intColumn, cell.Value
                    
                    'Kopiere nur die Sichtbaren zellen der Liste  
                    .UsedRange.SpecialCells(xlCellTypeVisible).Copy
                    With Workbooks.Add
                        'Inhalt in neues WB einfügen  
                        .Sheets(1).Range("A1").PasteSpecial xlPasteValues  
                        'Spalten an Inhalt anpassen (optische Hilfe)  
                        .Sheets(1).UsedRange.EntireColumn.AutoFit
                        'Exportdateiname  
                        strFilename = strExportPath & "\" & cell.Value & ".xlsx"  
                        ' Wenn Datei noch nicht existiert Speichere und schließe das neue Workbook, ansonsten  
                        ' frage nach ob sie überschrieben werden soll  
                        If Not fso.FileExists(strFilename) Then
                            .SaveAs strFilename
                            .Close True
                        Else
                            If MsgBox("Datei '" & strFilename & "' existiert bereits. Soll sie überschrieben werden?", vbExclamation Or vbYesNo) = vbYes Then  
                                .SaveAs strFilename
                                .Close True
                            Else
                                .Close False
                            End If
                        End If
                    End With
                End If
            End With
            ' Notiere den Status des Namens in der Liste  
            cell.Offset(0, 1).Value = "Fertig."  
        End If
    Next
End With

'cleanup  
Set fso = Nothing

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "Fertig", vbInformation  


End Sub