Neue Datei pro Zeile erzeugen - aber gleichen Inhalt zusammenfügen

[metallimani]

Hallo,
in diesem Forum bin ich auf die Möglichkeit gestoßen aus jeder Zeile eine extra Datei erzeugen zu lassen.

http://www.office-loesung.de/ftopic612960_0_0_asc.php

Nun kommt es natürlich vor, dass ich in einer Zeile in Spalte A mehrmals den selben Inhalt habe (z.B. Bremen - Klaus Dieter, Bremen - Herbert Schmitz, Düsseldorf - Bärbel Petersen...)

Wie krieg ich Excel dazu eine Datei mit BREMEN anzulegen und dort jede Zeile reinzulegen welches in der Spalte A "Bremen" enthält... usw.

Ich hoffe ihr versteht was ich meine.

Der Aufbau der Spalten und auch die Überschrit und Inhalt soll dann dementsprechend der Vorlage sein (also alle Daten die noch folgen - Adresse, Wohnort...Telefon...)

Danke

PS: Die Namen und Adressen sind nur Beispiele - für meine Zwecke kommen dort andere Daten zum tragen

[schauan]

Hallöchen,

das könnte so gehen:

Code:

Option Explicit

Sub test()
    'Variablendeklarationen
    Dim rng As Range, wb As Workbook
    'Flackern aus
    Application.ScreenUpdating = False
    'mit dem aktiven Blatt
    With ActiveSheet
        'Schleife ab A2 bis zur letzten gefuellten Zelle in Spalte A
        For Each rng In .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
            'Wenn in der Zelle was anderes steht als in der vorherigen, dann
            If rng.Value <> rng.Offset(-1).Value Then
                'neue Datei erstellen
                Set wb = Workbooks.Add
                'Ueberschriftszeile kopieren und einfuegen
                .Rows(1).Copy wb.Sheets(1).Rows(1)
            'Ende Wenn in der Zelle was anderes steht als in der vorherigen, dann
            End If
                'Daten kopieren und unter letzte gefuellte Zelle im Ziel einfuegen
                rng.EntireRow.Copy _
                   wb.Sheets(1).Cells(wb.Sheets(1).Rows.Count, 1).End(xlUp).Offset(1)
            'Wenn in der Zelle was anderes steht als in der naechsten, dann
            If rng.Value <> rng.Offset(1).Value Then
                'Zieldate speichern unter ...
                wb.SaveAs Filename:="C:\Test\" & rng & "Top10.xlsx", FileFormat:=51
                'Zieldatei schliessen
                wb.Close False
            End If
        'Ende Schleife ab A2 bis zur letzten gefuellten Zelle in Spalte A
        Next rng
    'Ende mit dem aktiven Blatt
    End With
    'Flackern an
    Application.ScreenUpdating = True
End Sub