Liste auf mehrere Arbeitsblätter aufteilen

Hallo,
ich habe eine lange Liste, die auf 20 bis 30 Arbeitsmappen aufgeteilt werden müssen.
zB alle Zeilen mit einem bestimmten Text oder Zahl in Spalte A.
In einer weiteren Zelle steht die Versionsnummer des Blattes, zB in D1: Version 1
In die bereits vorhandenen Arbeitsblätter sollen dann alle Zeilen mit dem Text in ein Blatt mit dem Namen Version 1 aus Zelle D1 kopiert werden. (ohne Makro würde ich nach dem Text filtern und dann in eine neue Arbeitsmappe kopieren)
Die Information - welche Zeilen in welche Arbeitsmappen kopiert werden, soll mittels einer eigenen Tabelle erfolgen. In diesem Tabellenblatt steht zB in Spalte A der Dateinamen und in Spalte B der Text, nach dem gefiltert wird und dessen Zeilen der Liste dann in die Arbeitsmappe kopiert werden. Alle Datein sind im gleichen Verzeichnis.
Wenn ich dann einmal die Liste ergänze oder eine neue Liste hineinfüge, dann würde ich in Zelle D1 Version 2 eingeben und die kopierten Zellen sollen dann in die Arbeitsblätter mit dem neuen Blatt Version 2 kopiert werden.
Danke nochmals im Voraus.
Grüße
René
Hier eine Beispieldatei:
https://www.herber.de/bbs/user/70331.xls
noch ein paar Zusatzfragen von Franz:
1: Nach welchen Spalten sollen die Daten sortiert sein, wenn sie in die Zieltabellen kopiert werden?
- nach Spalte A
2: Sind die Tabellen "Version 1", 2Version 2" etc. in den Zieldateien immer schon vorhanden? Oder müssen diese ggf. erst angelegt werden?
- Tabellenblätter (zumindest Version 1) sind vorhanden, wenn aber nicht, dann sollen Sie angelegt werden.
3: Muss vor dem Kopieren geprüft werden, ob ein Artikel in dem entsprechenden Versionsblatt schon vorhanden ist? Was soll passieren, falls Ja?
- Ja, es soll das alte Blatt gelöscht werden und die neuen Daten sollen eingefügt werden.
4: Ist der Autofilter im Blatt "Aufzuteilende Tabelle" immer aktiv?
- Nein
PS: Nochmals Danke an Tino, leider habe ich das Makro nicht zum laufen gebracht. Ist eine Antwort auf eine abgeschlossene Frage nicht mehr möglich?

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Benutzer

Hallo René,
ich habe nicht genau das, was Du brauchst, jedoch ähnlich.
Das Makro "CopyWithValue", bei dem mich Franz sehr unterstützt hat, macht im Prinzip genau das, was Du suchst, nur noch nicht mit den Versionen berücksichtigt. Es legt im gleichen Ordner der Ursprungsdatei neue Arbeitsmappen mit vorgegebenen Namen an oder befüllt bereits vorhandene Dateien mit neuen Daten.
Im letzten Abschnitt kannst Du im VBA-Code eingeben, 1. nach welchem (Text)-Wert, 2. in welcher Spalte gesucht werden soll, 3. wie die Zieldatei benannt werden soll und 4. optional noch ein Passwort für die Zieldatei vergeben.
Ist voraussichtlich nicht die endgültige Lösung für Deine Aufgabe, jedoch ein brauchbarer Ansatz.
Viele Grüße,
Heidrun
Option Explicit

Private Sub SaveWithValues(testValue As String, column As String, _
sheetName As String, Optional sPassword As String = "")
Dim rootSheet As Object
Dim newSheet As Object
Dim workRange As Range
Dim destinationRange As Range
Dim currentRow As Range
Dim strValue As String
Dim counter As Integer, Spalte
Dim row As String
Dim wbZiel As Workbook, sWorkbook As String
Application.StatusBar = "Bearbeite Datei für """ & testValue & """"
counter = 1 'Zeile mit Spaltentiteln im Zielblatt    -   ggf. anpassen
Set rootSheet = ActiveSheet
Set workRange = rootSheet.UsedRange
On Error GoTo Fehler
'Name der Datei für den Vertriebs-Ing.
sWorkbook = ActiveWorkbook.Path & Application.PathSeparator & sheetName & ".xls"
'Prüfen ob Datei vorhanden
If Dir(sWorkbook)  "" Then
'Datei ist schon vorhanden
Set wbZiel = Workbooks.Open(Filename:=sWorkbook, Password:=sPassword, _
IgnoreReadonlyRecommended:=True)
Set newSheet = wbZiel.Worksheets(sheetName)
'Altdaten unterhalb der Spaltentitel löschen
With newSheet
If .Cells.SpecialCells(xlCellTypeLastCell).row > counter Then
.Range(.Rows(counter + 1), _
.Rows(.Cells.SpecialCells(xlCellTypeLastCell).row)).Clear
End If
End With
Else
'Neue Datei mit einem Tabellenblatt anlegen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
Set newSheet = wbZiel.Worksheets(1)
'Datei im älteren Format speichern
If Val(Left(Application.Version, 2)) >= 12 Then
'Excel 2007 und neuer
wbZiel.SaveAs Filename:=sWorkbook, FileFormat:=56, _
Password:=sPassword '56 = xlExcel8
Else
'Ältere Excel-Versionen
wbZiel.SaveAs Filename:=sWorkbook, FileFormat:=-4143, _
Password:=sPassword ' -4143 = xlWorkbookNormal
End If
NeuesBlatt:
newSheet.Name = sheetName
With newSheet
'Standard-Fontgröße festlegen
wbZiel.Styles("Standard").Font.Size = 10
'Spaltenbreiten übernehmen
For Spalte = 1 To rootSheet.Cells.SpecialCells(xlCellTypeLastCell).column
.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next
End With
'Titelzeile kopieren
rootSheet.Rows(1).Copy newSheet.Rows(counter)
'Fenster fixieren
Range("D2").Select
ActiveWindow.FreezePanes = True
End If
newSheet.Activate
'Daten übertragen
For Each currentRow In workRange.Rows
strValue = CStr(currentRow.Range(column & 1).Text)
If strValue = testValue Then
counter = counter + 1
Set destinationRange = newSheet.Rows(counter)
currentRow.Copy destinationRange
End If
Next
wbZiel.Close savechanges:=True
Fehler:
With Err
Select Case .Number
Case 0 ' Alles OK
Case 9 'Blatt fehlt
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "Fehlendes Tabellenblatt """ & sheetName & """ wird angelegt", _
vbInformation + vbOKOnly, "Vertreter-Arbeitsmappen erstellen/ausfüllen"
Application.ScreenUpdating = False
Set newSheet = wbZiel.Worksheets.Add
Resume NeuesBlatt
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbInformation + vbOKOnly, "Vertreter-Arbeitsmappen erstellen/ausfüllen"
Application.ScreenUpdating = False
End Select
End With
Application.StatusBar = False
End Sub

Sub KB_vereinzeln_Arbeitsmappen()
Application.ScreenUpdating = False
'SaveWithValues testValue:="NameIng", column:="F", sheetName:="NameIng", _
sPassword:= "AXBc120"
SaveWithValues "Peter", "F", "Peter", "PW_Test"
SaveWithValues "Steffen", "F", "Steffen"
SaveWithValues "Heinz", "F", "Heinz"
SaveWithValues "Sigmar", "F", "Sigmar"
SaveWithValues "Manfred", "F", "Manfred"
SaveWithValues "Kurt", "F", "Kurt"
Application.ScreenUpdating = True
MsgBox "Daten wurden in Arbeitsmappen kopiert"
End Sub

Beliebteste Forumthreads (12 Monate)

Liste auf mehrere Arbeitsblätter aufteilen

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

134 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Liste auf mehrere Arbeitsblätter aufteilen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

134 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread