Live-Forum - Die aktuellen Beiträge
Datum
Titel
17.06.2024 19:56:24
17.06.2024 19:39:46
Anzeige
Archiv - Navigation
1164to1168
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Liste auf mehrere Arbeitsblätter aufteilen

Liste auf mehrere Arbeitsblätter aufteilen
Rene
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?

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Liste auf mehrere Arbeitsblätter aufteilen
06.07.2010 15:17:07
Hei.Fisch
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
Anzeige

134 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige