Komplette Kundenliste in einzelne Listen aufteilen

Hi,

durch mangelnde VBA Kenntnisse und dadurch, dass ich weder über Google noch direkt hier im Forum fündig werde, muss ich nun doch mal einen Beitrag schreiben.

Situation:
Ich habe eine Liste mit all unseren Kunden. (ca. 15.000 Kontakte +/-)
Ich möchte gerne ein Skript haben, welches anhand der Kundenummer (Debitornummer) mir einzelne Exceldateien erstellt.
Als Name sollen die Excelliste den Kundennamen haben und die Kundennummer

Es kann also sein, das Kunde "Musterfirma" 5 Kontakte hat. Alle Kontakte haben die gleiche Kundennummer (12345).
Von diesen 5 Kontakten soll das Skript nun alle 5 Stück zusammen in eine Excelliste packen und die Liste wie folgt bennen: "12345 Musterfirma.xlxs"
In jede der Exceltapellen soll auch die Ursprüngliche Kopfzeile enthalten sein

Die Kopfzeile soll er optimalerweise aus der Quelldatei übernehmen. Falls das nicht geht, bitte kurz schreiben, dann schreibe ich die einzelnen Felder die ich benötige dazu :)

Beispieldateien:
Quelle:
https://www.herber.de/bbs/user/168171.xlsx

Ergebisse:
https://www.herber.de/bbs/user/168172.xlsx (sollte eigentlich heißen : 12345 Musterfirma.xlsx)
https://www.herber.de/bbs/user/168173.xlsx (sollte eigentlich heißen : 55555 Beispielfirma.xlsx)

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Aufteilen() Dim Zelle1 As Range Dim Zelle2 As Range Dim wb As Workbook With ActiveSheet.UsedRange Set wb = Workbooks.Add(xlWBATWorksheet) .Rows(1).Copy wb.Sheets(1).Cells(1, 1) .Sort Key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlYes Set Zelle2 = .Cells(1, 1) ActiveSheet.Select With wb.Sheets(1) Do Set Zelle1 = Zelle2.Offset(1, 0) If Zelle1.Value = "" Then Exit Do Set Zelle2 = Zelle1.EntireColumn.Find(what:=Zelle1.Value, lookat:=xlWhole, searchdirection:=xlPrevious) Range(Zelle1, Zelle2).EntireRow.Copy .Cells(2, 1) wb.SaveAs ThisWorkbook.Path & Application.PathSeparator & Zelle1.Value & " " & Zelle1.Offset(0, 1).Value, 51 .UsedRange.Offset(1, 0).Clear Loop End With End With wb.Close False End Sub

Option Explicit Public Sub Separieren() Dim TB As Worksheet, Arr, i As Integer, Pfad As String, Datei As String On Error GoTo Ende Application.ScreenUpdating = False Application.DisplayAlerts = False Pfad = "D:\Excel\temp\" Arr = Evaluate("=Unique(Filter(tabelle1!A:B, tabelle1!A:A > 0))") For i = 2 To UBound(Arr) Datei = Arr(i, 1) & " " & Arr(i, 2) Set TB = Worksheets.Add(After:=Sheets(1)) With TB .Name = Datei .Cells(1, 1).Formula2 = "=FILTER(Tabelle1!A:U,(Tabelle1!A:A=Tabelle1!$A$1)+(Tabelle1!A:A=" & Arr(i, 1) & "))" .UsedRange.Value = .UsedRange.Value .Move End With With ActiveWorkbook .SaveAs Filename:=Pfad & Datei, FileFormat:=xlOpenXMLWorkbook .Close End With Next Ende: Application.DisplayAlerts = True If Err.Number > 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description End Sub

Sub ErstelleKundenExcelDateien()

    Dim wsKundenliste As Worksheet

    Dim rngKunden As Range

    Dim rngKunde As Range

    Dim Kundennummer As String

    Dim Kundennamen As String

    Dim NeueDatei As Workbook

    Dim Kopfzeile As Range

    Dim QuellZeile As Range

    Dim NeueZeile As Range

    Dim Speicherpfad As String

    Dim AbbruchZeit As Date

    

    ' Speicherpfad anpassen

    Speicherpfad = "C:\Users\hkurz\Downloads\TEST\Neuer Ordner\"

    

    ' Arbeitsblatt mit Kundenliste

    Set wsKundenliste = ThisWorkbook.Sheets("Kundenliste")

    Set rngKunden = wsKundenliste.Range("A2:A" & wsKundenliste.Cells(Rows.Count, 1).End(xlUp).Row)

    

    ' Dauer in Sekunden festlegen

    Dim duration As Long

    duration = 10  ' 1 Minute

    

    ' Startzeit für den Timer

    AbbruchZeit = Now + TimeSerial(0, 0, duration)

    

    ' Schleife durch alle Kunden

    For Each rngKunde In rngKunden

        Kundennummer = rngKunde.Value

        Kundennamen = rngKunde.Offset(0, 1).Value ' Annahme: Kundennamen in Spalte B

        

        ' Prüfen, ob Datei bereits vorhanden ist

        If Dir(Speicherpfad & Kundennummer & " " & Kundennamen & ".xlsx") = "" Then

            ' Neue Excel-Datei erstellen

            Set NeueDatei = Workbooks.Add

            NeueDatei.SaveAs Speicherpfad & Kundennummer & " " & Kundennamen & ".xlsx"

            

            ' Kopfzeile aus der Quelldatei übernehmen (Annahme: Kopfzeile in Zeile 1)

            Set Kopfzeile = wsKundenliste.Rows(1)

            Kopfzeile.Copy Destination:=NeueDatei.Sheets(1).Rows(1)

        Else

            ' Datei bereits vorhanden, öffnen

            Set NeueDatei = Workbooks.Open(Speicherpfad & Kundennummer & " " & Kundennamen & ".xlsx")

        End If

        

' Zeilen aus der Quelldatei übernehmen (Annahme: Daten beginnen in Zeile 2)

        For Each QuellZeile In wsKundenliste.Range("A2:A" & wsKundenliste.Cells(Rows.Count, 1).End(xlUp).Row)

            If QuellZeile.Value = Kundennummer Then

                Set NeueZeile = NeueDatei.Sheets(1).Cells(NeueDatei.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)

                QuellZeile.EntireRow.Copy Destination:=NeueZeile

            End If

        Next QuellZeile



 NeueDatei.Close SaveChanges:=True ' Speichern und schließen der Datei

        

        ' Überprüfen, ob die Abbruchzeit erreicht ist

        If Now >= AbbruchZeit Then

            Dim userResponse As String

            userResponse = InputBox("Möchtest du das Skript abbrechen? (ja/nein)", "Abbruchabfrage")

            If LCase(userResponse) = "ja" Then

                MsgBox "Skript wird abgebrochen."

                Exit Sub

            ElseIf LCase(userResponse) = "nein" Then

                duration = InputBox("In wie vielen Sekunden möchtest du erneut gefragt werden?", "Wartezeit festlegen")

                AbbruchZeit = Now + TimeSerial(0, 0, duration)

            Else

                MsgBox "Ungültige Eingabe. Bitte antworte mit 'ja' oder 'nein'."

            End If

        End If

    Next rngKunde

End Sub

Das habe ich von der KI erstellen lassen.
Hat ein paar Korrekturen benötigt, weil da irgendwas nicht ganz sauber ist. Habe mir Für meine Testzwecke auch die Funktion eines Stops einbauen lassen. Also nicht wundern.
Gibt sogar Kommentare ganz gut an. Den Ordnerpfad hat er immer seprerat gelassen, bis ich ihm direkt meinen genannt habe, weil es mir auf die Nerven ging es immer abändern zu müssen

Beliebteste Forumthreads (12 Monate)

Komplette Kundenliste in einzelne Listen aufteilen

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Komplette Kundenliste in einzelne Listen aufteilen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread