Werte suchen und kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub KundenSheetsErstellen() Dim ws As Worksheet Dim KundenNr As Range Dim KundenName As Range Dim KundenSheet As Worksheet Dim LastRow As Long Dim i As Long Dim NextRow As Long ' Das aktive Blatt als Arbeitsblatt setzen Set ws = ActiveSheet ' Finde die letzte Zeile mit Daten in Spalte A LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' Setze die Bereichsvariablen für Kundennummer und Kundennamen Set KundenNr = ws.Range("A4:A" & LastRow) Set KundenName = ws.Range("B4:B" & LastRow) ' Schleife durch jeden Kunden For i = 1 To KundenNr.Rows.Count ' Überprüfe, ob bereits ein Sheet für diesen Kunden existiert On Error Resume Next Set KundenSheet = ThisWorkbook.Sheets(KundenNr.Cells(i, 1).Value) On Error GoTo 0 ' Wenn kein Sheet vorhanden ist, erstelle eins If KundenSheet Is Nothing Then Set KundenSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) KundenSheet.Name = KundenNr.Cells(i, 1).Value ' Kopiere die Kundeninformationen in das neue Sheet NextRow = 1 Else ' Wenn ein Sheet für diesen Kunden existiert, erhalte die nächste freie Zeile NextRow = KundenSheet.Cells(KundenSheet.Rows.Count, "A").End(xlUp).Row + 1 End If ' Kopiere die Kundeninformationen in das neue Sheet ws.Rows(i + 3).Copy Destination:=KundenSheet.Rows(NextRow) Next i End Sub

Schau mal:

Sub DatenAufteilen()

    Dim wsQuelle As Worksheet

    Dim wsZiel As Worksheet

    Dim KundenNr As Range

    Dim ZielZeile As Long

    Dim i As Long

    Dim KundenNrValue As String

    

    ' Definiere das Quellblatt (Blatt mit der Tabelle)

    Set wsQuelle = ThisWorkbook.Sheets("Quellblatt") ' Ändere "Quellblatt" entsprechend dem Namen deines Quellblatts

    

    ' Schleife durch jede Zeile in Spalte A des Quellblatts

    For Each KundenNr In wsQuelle.Range("A4:A" & wsQuelle.Cells(Rows.Count, 1).End(xlUp).Row)

        KundenNrValue = KundenNr.Value

        ' Überprüfe, ob für diese Kundennummer bereits ein Zielblatt existiert

        If Not WorksheetExists(KundenNrValue) Then

            ' Erstelle ein neues Zielblatt für den Kunden

            Set wsZiel = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

            wsZiel.Name = KundenNrValue

            ' Kopiere die ersten drei Zeilen (Überschriften) von der Quelle zum Zielblatt

            For i = 1 To 3

                wsQuelle.Rows(i).Copy wsZiel.Rows(i)

            Next i

            ZielZeile = 4 ' Startzeile für das Zielblatt (nach den Überschriften)

        Else

            ' Falls das Zielblatt bereits existiert, hole das existierende Zielblatt

            Set wsZiel = ThisWorkbook.Sheets(KundenNrValue)

            ' Bestimme die nächste leere Zeile im Zielblatt

            ZielZeile = wsZiel.Cells(Rows.Count, 1).End(xlUp).Row + 1

        End If

        

        ' Kopiere die Daten des Kunden von der Quelle zum Zielblatt

        For i = 1 To wsQuelle.Cells(KundenNr.Row, Columns.Count).End(xlToLeft).Column

            wsQuelle.Cells(KundenNr.Row, i).Copy wsZiel.Cells(ZielZeile, i)

        Next i

    Next KundenNr

    

    MsgBox "Daten wurden erfolgreich aufgeteilt.", vbInformation

End Sub



Function WorksheetExists(ByVal WorksheetName As String) As Boolean

    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Sheets

        If ws.Name = WorksheetName Then

            WorksheetExists = True

            Exit Function

        End If

    Next ws

    WorksheetExists = False

End Function

Ist nicht auf meinen Mist gewachsen. ;-)
Müsste aber so ziemlich das machen, was du vorhast. Könnte allerdings bei sehr großen Datenbeständen etwas Zeit beanspruchen.

Viele Grüße

Wenn du meinen vorherigen Code ausführst, wird die Tabelle immer wieder neu ausgelesen und wenn da schon ein Tabellenblatt existiert, werden wieder die gleichen Daten unten angehängt.
Das scheint mir sehr fehlerträchtig zu sein. Ich weiß ja nicht, wie deine Quelldaten aussehen.

In angehängter Datei wird geprüft, ob für jede Kundennummer in den Originaldaten ein eigenes Tabellenblatt existiert. Wenn nicht, wird es erstellt und in Zelle A4 wird automatisch eine Formel geschrieben, die aus den Originaldaten alle passenden Zeilen filtert. Das hat den Vorteil, dass keine Daten doppelt ausgelesen werden. Man kann in den Originaldaten immer neue Zeilen befüllen. Die bestehenden Tabellenblätter werden aktualisiert und bei neuen Kundennummern wird beim Start des Makros ein entsprechend neues Tabellenblatt erzeugt. Bestehende Tabs sind durch die Formel immer aktuell.

https://www.herber.de/bbs/user/168368.xlsm

Dann kann man aber auch noch das Design für die neu angelegten Tabs bereits im Marko festlegen.

Schau halt mal.

Viele Grüße

Kulo

Sub KundenSheets_herstellen() Dim Dic Dim Arr Dim i As Long Dim Elt Dim ws As Worksheet Dim j As Long Set Dic = CreateObject("Scripting.Dictionary") 'Besser wäre die Anbindung der Bibliothek "Microsoft Scripting Runtime" Arr = ActiveSheet.UsedRange 'Aufbau der Auflistung alle Kunden For i = LBound(Arr, 1) To UBound(Arr, 1) Dic(Arr(i, 1)) = 1 Next Application.EnableEvents = False Application.ScreenUpdating = False 'Einzelne Kunde durchlaufen For Each Elt In Dic.Keys Set ws = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)) 'neue ws ws.Name = Elt For i = LBound(Arr, 1) To UBound(Arr, 1) If Arr(i, 1) = Elt Then With ws.Cells(Rows.Count, "A").End(xlUp) For j = LBound(Arr, 2) To UBound(Arr, 2) .Offset(1, j).Value = Arr(i, j) Next End With End If Next Next Application.ScreenUpdating = True Application.EnableEvents = True End Sub

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte suchen und kopieren

4 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)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread