Tabellenblätter erstellen mit Daten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi,
versuch mal:
https://www.herber.de/bbs/user/150137.xlsm
Das Makro, das du starten musst, heißt sbCreateCustomerTables
Es ist egal, welches Tabellenblatt zum Zeitpunkt der Makro-Ausführung gerade aktiv ist.
Das Makro...
...durchläuft alle Datenzeilen, beginnend in Zeile 2, in der Tabelle Kunden
...zuerst wird der jeweilige Eintrag in Spalte A in zwei einzelne Werte, Kd-Nummer + Kd-Name aufgeteilt
...jetzt startet ein weiterer Durchlauf aller Datenzeilen in Tabelle Kundendaten
...hier wird geprüft, ob Eintrag in Spalte B mit Wert Kd-Nummer UND Eintrag in Spalte A mit Kd-Name übereinstimmt (unter Berücksichtigung, dass alle überflüssigen Leerzeichen ignoriert werden)
...wenn Übereinstimmung gefunden...
......wird für jeden Kunden 1x ein neues Tabellenblatt hinzugefügt
......das neue Tabellenblatt erhält als Namen denselben Eintrag wie aus Tabelle Kunden
......alle gefundenen Datensätze werden in das jeweilige neue Tabellenblatt eingetragen - es geht weiter mit dem nächsten Kunden
Mir ist aufgefallen, dass deine Tabelle Kunden über 160 genutzte Zeilen enthält, obwohl in Spalte A ab Zeile 15 kein Eintrag mehr vorhanden ist.
Das wird in meinem Code zwar berücksichtigt, besser wäre aber, wenn du im Original alle leeren Zeilen wirklich löschst = die ganzen Zeilen, nicht nur die Inhalte.
Hilfts?
Ciao
Thorsten

Sub CreateSheets() Dim strBlatt As String Dim rngKunden As Range Dim arrDaten, arrBlatt() Dim lngKdNr As Long Dim i As Long, j As Long, n As Long Dim wksKunde As Worksheet, wksKdDaten As Worksheet Set wksKdDaten = Sheets("Kundendaten") arrDaten = wksKdDaten.Cells(1, 1).CurrentRegion With Sheets("kunden") For Each rngKunden In .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)) n = 1 lngKdNr = Split(rngKunden)(0) strBlatt = rngKunden ReDim arrBlatt(1 To WorksheetFunction.CountIf(wksKdDaten.Columns(2), lngKdNr) + 1, 1 To UBound(arrDaten, 2)) For j = 1 To UBound(arrDaten, 2) arrBlatt(1, j) = arrDaten(1, j) Next For i = 2 To UBound(arrDaten) If arrDaten(i, 2) = lngKdNr Then n = n + 1 For j = 1 To UBound(arrDaten, 2) arrBlatt(n, j) = arrDaten(i, j) Next j End If Next i On Error Resume Next Set wksKunde = Sheets(strBlatt) On Error GoTo 0 If wksKunde Is Nothing Then Set wksKunde = Worksheets.Add wksKunde.Name = strBlatt Else wksKunde.Cells.Clear End If wksKunde.Cells(1, 1).Resize(UBound(arrBlatt), UBound(arrBlatt, 2)) = arrBlatt wksKunde.Columns.AutoFit Set wksKunde = Nothing Next rngKunden End With End Sub

Beliebteste Forumthreads (12 Monate)

Tabellenblätter erstellen mit Daten

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabellenblätter erstellen mit Daten

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread