Anzeige
Archiv - Navigation
1276to1280
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

EXCEL-Datei Splitten per MAKRO

EXCEL-Datei Splitten per MAKRO
JOE-ALF
Hallo zusammen,
ich müsste eine größere Excel-Datei in Abhängigkeit der Spalte A (sofern ein neuer Eintrag) in _ mehrere Dateien aufteilen und abspeichern. Dazu habe ich auch ein MAKRO gefunden. Allerdings müsste nun noch die Fußzeile, der Drucktitel und das Format (Größe der Schrift, Zeilenhöhe etc.) von der Ursprungsdatei übernommen werden. Ebenso wäre es schön, wenn das Tabellenblatt den Namen der Datei hat. Könnte mir jemand den Code umbauen? Habe leider noch nicht so viel Kentnisse. Danke schon Mal ...

Sub splitten()
Dim wbMappe As Workbook, _
wbMappeAlt As Workbook, _
lngZeile As Long, _
strPfad As String
'Pfad festlegen (mit "\")
strPfad = "C:\Temp\"
'Erstmal alles in eine neue Mappe schaufeln
ActiveSheet.UsedRange.Cut
Set wbMappe = Workbooks.Add
wbMappe.Sheets(1).Paste
Application.CutCopyMode = False
Do
'falls vorhanden, die letzte Mappe speichern + schließen
If Not wbMappeAlt Is Nothing Then
wbMappeAlt.SaveAs Filename:=strPfad & _
CStr(wbMappeAlt.Sheets(1).Cells(2, 1).Value) & ".xls"
wbMappeAlt.Close
Set wbMappeAlt = Nothing
End If
'nächsten Bruch suchen
lngZeile = 2 'wegen der Überschriften in Z. 2 beginnen!
Do
lngZeile = lngZeile + 1
'wenn Ende, dann Ende
If Cells(lngZeile, 1) = "" Then Exit Do
Loop Until Cells(lngZeile, 1)  Cells(lngZeile - 1, 1)
'wenn Ende, dann Ende
If Cells(lngZeile, 1) = "" Then Exit Do
'Rest ausschneiden und in neue Mappe verschieben
Range(Cells(lngZeile, 1), Cells(ActiveSheet.UsedRange.Rows.Count, _
ActiveSheet.UsedRange.Columns.Count)).Cut
Set wbMappeAlt = ActiveWorkbook 'Alte Mappe merken
Set wbMappe = Workbooks.Add
Application.Goto wbMappe.Sheets(1).Cells(2, 1)
ActiveSheet.Paste
wbMappeAlt.Sheets(1).Rows(1).Copy Destination:=ActiveSheet.Rows(1)
Application.CutCopyMode = False
Loop
'Am Ende die Aktive Mappe speichern und schließen.
ActiveWorkbook.SaveAs Filename:=strPfad & _
CStr(ActiveWorkbook.Sheets(1).Cells(2, 1).Value) & ".xls"
ActiveWorkbook.Close
End Sub

VB, JOE-ALF

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: EXCEL-Datei Splitten per MAKRO
04.09.2012 20:36:50
fcs
Hallo Joe-Alf,
damit die Übernahme der Information aus "Seite-einrichten" funktioniert hab ich einen anderen Weg beschritten.
1. Statt nur die Daten in die temporäre Arbeitsmappe zu kopieren wird das aktive Blatt komplett mit allem Drum-und-Dran in eine neue Arbeitsmappe kopiert.
2. Aus dem kopierten Blatt wird ein Muster erstellt, das nur noch die Daten aus der 1. Zeile (=Titelzeile?) enthält.
3. Bei Wertewechsel in Spalte A wird immer das Musterblatt kopiert und anschliessend der Zeilenblock mit den Daten. Dann Blatt umbenannt und Datei gespeichert.
4. Nach Abschluss der Kopiervorgänge wird die temporäre Arbeitsmappe ohne Speichern geschlossen.
In der Text-Datei sind auch noch 2 Test-Zeilen (vor und nach dem Speichern der Dateien). Diese unterdrücken die Warnmeldung, wenn Datei mit identischem Namen schon vorhanden. Diese 2 Zeilen kannst du auch wieder löschen.
Gruß
Franz
Textdatei mit Code: https://www.herber.de/bbs/user/81704.txt
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige