Clever-Excel-Forum

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

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

metallimani

schauan