EXCEL-Datei Splitten per MAKRO
JOE-ALF
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
Anzeige