.xls Exel Datei Splitten nach Kundennummer mit batch

Sub Workbook_Open()
Aktualisieren
End Sub

Sub Aktualisieren()
   Dim varItem As Variant
   Dim strName As String
   
   On Error GoTo ErrHandler
   
   Application.EnableEvents = True 'Makros einschalten !  
   
   For Each varItem In Array("C:\Ordner_der_zu_bearbeitenden_Datei\") 'Pfad muss mit "\" enden  
      strName = Dir(varItem & "*.xls")  
      Do While Len(strName) > 0
         Workbooks.Open varItem & strName, UpdateLinks:=True
         'MsgBox ActiveWorkbook.FullName  
'##  
'Quelle  
Const AbZeileQuelle As Integer = 2 'erste Datenzeile  
Const SpalteQuelleKNr As String = "A"  
Const SpalteQuelleName As String = "B"  
Const AbSpalteDaten As String = "C"  

'Ziel  
Const Zielpfad As String = "C:\Zielordner\" 'Pfad muss mit "\" enden  
Const AbZeileZiel As Integer = 1 'Kopfzeile  
Const AbSpalteZiel As String = "A"  
Dim Kopfzeile() As Variant
Kopfzeile = Array("Artikelnummer", "Bezeichnung", "Menge") 'Kopfzeile = Spaltenüberschriften in Zieldatei  

Spalten = UBound(Kopfzeile) + 1 'Anzahl der Datenspalten lt festgelegter Kopfzeile  
Set Quelle = ActiveWorkbook.ActiveSheet
ZeileQuelle = AbZeileQuelle
With Quelle
    KNr = .Cells(ZeileQuelle, SpalteQuelleKNr).Value  'KNr auslesen  
    KNrZuletzt = ""  
    Do While KNr <> "" 'solange Daten vorhanden (KNr-Spalte nicht leer)  
        If KNr <> KNrZuletzt Then 'neuer Kunde?  
            If Not KNrZuletzt = "" Then 'Wenn nicht allererster Datensatz,  
                Zieldatei.ActiveSheet.Cells.EntireColumn.AutoFit 'optimale Spaltenbreite festlegen,  
                Zieldatei.SaveAs Zielpfad & Dateiname 'Zieldatei speichern und  
                Zieldatei.Close 'schließen  
            End If
            Dateiname = .Cells(ZeileQuelle, SpalteQuelleName).Value 'Dateinamen auslesen  
            Set Zieldatei = Workbooks.Add 'neue Datei erstellen  
            ZeileZiel = AbZeileZiel
            Zieldatei.ActiveSheet.Cells(ZeileZiel, AbSpalteZiel).Resize(1, Spalten).Value = Kopfzeile 'Kopfzeile eintragen  
            KNrZuletzt = KNr
        End If
        ZeileZiel = ZeileZiel + 1 'nächste Zeile in Zieltabelle  
        .Cells(ZeileQuelle, AbSpalteDaten).Resize(1, Spalten).Copy Zieldatei.ActiveSheet.Cells(ZeileZiel, AbSpalteZiel) 'Datenspalten in Zieldatei kopieren  

        ZeileQuelle = ZeileQuelle + 1 'nächste Zeile in Quelltabelle  
        KNr = Quelle.Cells(ZeileQuelle, SpalteQuelleKNr).Value 'KNr auslesen  
    Loop

    If Not KNrZuletzt = "" Then 'Wenn nicht allererster Datensatz,  
        Zieldatei.ActiveSheet.Cells.EntireColumn.AutoFit 'optimale Spaltenbreite festlegen,  
        Zieldatei.SaveAs Zielpfad & Dateiname 'Zieldatei speichern und  
        Zieldatei.Close 'schließen  
    End If
End With

'###  
         strName = Dir
      Loop
   Next
   
   Application.EnableEvents = True

ErrHandler:
   If Err.Number Then
      MsgBox Err.Description, vbCritical, Err.Number
      Resume Next
   End If
End Sub