Frage Entwicklung Batch & Shell

gelöst .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