Zeilen sortieren und in Einzel Blätter kopieren.

[roco48]

Hallo zusammen,

ich komme nicht weiter und würde gerne Eure Hilfe in Anspruch nehmen.
Mein Exceltabelle besteht aus einer jedesmal unterschiedlicher Anzahl an Zeilen.
Jede Zeile beginnt mit einem eindeutigen Eintrag, bestehend aus einer Zahl und einem Namen. Z.B.; 12345-Max Mustermann.
Nach einer unbestimmten Anzahl von Zeilen mit Max Mustermann, kommt der nächste z.B.: 98767-Fritze Flink.

Jetzt will ich per VBA, das alle eindeutigen Namen erkannt, und auf ein jeweils neues Tebellenbaltt kopiert werden.
Die Überschrift aus der Tabelle1 soll jeweils auch in das neue Tabellenblatt kopiert werden und das Tabellnblatt soll den Namen des Inhaltes aus A bekommen.
Hier in dem Beispiel 12345-Max Mustermann.
Dazu habe ich folgendes VBA Script erstellt ( im Anhang).
Das funktioniert auch ABER - es kopiert ausschließlich den letzten Satz in ein neues Blatt. Obwohl aktuell 22 unterschiedliche Inhalte in der Zeile A benannt sind.
Es gibt keinen Fehler beim kompilieren. 

Hat jemand einen Rat?

Herzlichen Dank

Rolf 
  VBA_Liste in neue Blätter kopieren.rtf (Größe: 2,3 KB / Downloads: 12)
Su

[oee]

Dein Code als Text-Datei bringt nix. Sollen wir die Datei dazu denn selber basteln?

[UweD]

Hallo

Dein Code durchläuft jedes mal alle Zeilen, das macht nur Sinn, wenn die Werte auch gemischt vorkommen. Ist doch laut deiner Aussage nicht so.

Ich habe für eine ähnliches Problem mal das hier geschrieben.

Hilft das?

Code:

Sub Gruppe_neues_Blatt()
    Dim Spalte As Integer, rr As Long, I As Long, TB1, TB2
    Set TB1 = ActiveSheet
    rr = TB1.Cells.SpecialCells(xlCellTypeLastCell).Row 'Letzte Zeile des gesamten Blattes
   
    Spalte = 1
    For I = rr To 2 Step -1
        If TB1.Cells(I, Spalte).Value <> "" And TB1.Cells(I - 1, Spalte).Value <> _
            TB1.Cells(I, Spalte).Value Then
           
            Sheets.Add After:=Sheets(Sheets.Count)
            Set TB2 = ActiveSheet
            TB1.Rows("1:1").Copy TB2.Cells(1, 1)
            TB1.Rows(I & ":" & rr).Copy TB2.Cells(2, 1)
            'TB1.Rows(I & ":" & rr).Delete xlUp
            TB2.Name = Trim(TB2.Cells(2, Spalte).Text)
            rr = I - 1
               
        End If
    Next
End Sub

LG UweD

[roco48]

Code:

Sub TeileNachNummernInSpalteA()
    Dim wsQuelle As Worksheet
    Dim wsZiel As Worksheet
    Dim letzteZeile As Long
    Dim zelle As Range
    Dim uniqueKeys As Object ' Dictionary für eindeutige Schlüssel
    Dim key As Variant
    Dim zielZeile As Long
   
    ' Quell-Arbeitsblatt festlegen
    Set wsQuelle = ThisWorkbook.Sheets("Tabelle1") ' Name des Hauptblatts
   
    ' Letzte Zeile in Spalte A ermitteln
    letzteZeile = wsQuelle.Cells(wsQuelle.Rows.Count, 1).End(xlUp).Row
   
    ' Dictionary für eindeutige Werte erstellen
    Set uniqueKeys = CreateObject("Scripting.Dictionary")
   
    ' Alle eindeutigen Werte aus Spalte A sammeln
    For Each zelle In wsQuelle.Range("A2:A" & letzteZeile)
        If Not IsEmpty(zelle.Value) Then
            If Not uniqueKeys.exists(CStr(zelle.Value)) Then
                uniqueKeys.Add CStr(zelle.Value), 1
            End If
        End If
    Next zelle
   
    ' Für jeden eindeutigen Wert ein neues Blatt erstellen
    For Each key In uniqueKeys.Keys
        ' Neues Blatt erstellen und benennen
        On Error Resume Next
        Set wsZiel = ThisWorkbook.Sheets(CStr(key))
        If wsZiel Is Nothing Then
            Set wsZiel = ThisWorkbook.Sheets.Add
            wsZiel.Name = CStr(key)
        End If
        On Error GoTo 0
       
        ' Überschrift aus der Haupttabelle kopieren
        wsQuelle.Rows(1).Copy Destination:=wsZiel.Rows(1)
       
        ' Zeilen mit dem aktuellen Schlüssel in das neue Blatt kopieren
        zielZeile = 2
        For Each zelle In wsQuelle.Range("A2:A" & letzteZeile)
            If CStr(zelle.Value) = key Then
                wsQuelle.Rows(zelle.Row).Copy Destination:=wsZiel.Rows(zielZeile)
                zielZeile = zielZeile + 1
            End If
        Next zelle
    Next key
   
    MsgBox "Die Zeilen wurden erfolgreich auf die Blätter verteilt.", vbInformation
End Sub

---

Stimmt, das ist das Problem.
Danke