Excel-Makro

Sub FilterAndCopyData()
    Dim wsList As Worksheet, wsData As Worksheet, strExportPath As String, strFilename As String, fso As Object, intColumn As Integer
    
    'Sheets festlegen  
    Set wsList = Sheets("Steuerung")  
    Set wsData = Sheets("Rohdaten")  
    
    'Exportpfad für die Dateien  
    strExportPath = ThisWorkbook.Path
    
    'Objekte  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    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