AW: Datei splitten
14.04.2011 13:25:56
fcs
Hallo Bodo,
hier mein Vorschlag.
Aus dem aktiven Blatt wird eine Musterdatei erstellt, in die dann jeweils 30 Zeilen kopiert werden.
Dabei bleiben dann auch alle Spaltenbreiten und anderen Formatierungen (unter Seite einrichten) des Tabellenblatts erhalten.
Gruß
Franz
'##############################################################
'# Windows Vista - Excel 2007 - VBA 6.5.1053 #
'# Modul: Allgemeines Modul #
'# Makro sollte auch unter Excel 2003 lauffähig sein #
Option Explicit
Sub Splitten_Tabelleninhalt()
'Inhalt des Tabellenblatts auf mehrere Dateien verteilen _
Dabei Musterdatei erstellen und gewünschte Inhalte kopieren
Dim wbQuelle As Workbook, wbZiel As Workbook, wbMuster As Workbook
Dim wksQuelle As Worksheet, wksZiel As Worksheet, wksMuster As Worksheet
Dim ZeileQuelle As Long, ZeileLetzte As Long, iCount As Long
Dim AnzTitel As Long, AnzZeilen As Long
Dim sPath As String, sDatei As String
AnzTitel = 4 'Anzahl der Titelzeilen - ### ggf. anpassen
AnzZeilen = 30 'Anzahl der Zeilen, die jedesmal kopiert werden sollen - ### ggf. anpassen
'Sicherheitsabfrage
If MsgBox("Daten des aktiven Tabellenblatts in Dateien mit jeweils " _
& AnzZeilen & " Zeilen splitten?", vbQuestion + vbYesNo, _
"Tabellenblattdaten splitten") = vbNo Then Exit Sub
'Quellmappe und Tabellenblatt setzen
Set wbQuelle = ActiveWorkbook
Set wksQuelle = ActiveSheet
'Ziel-Verzeichnis für die erstellten gesplitteten Dateien
sPath = wbQuelle.Path & Application.PathSeparator ' ### ggf. anpassen
'Name der Quelldatei ohne Dateinamenserweiterung
With wbQuelle
sDatei = Left(.Name, InStrRev(.Name, ".") - 1)
End With
'Anwendungseinstellungen für schnellere Makroausführung
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With wksQuelle
'Letzte Daten-Zeile im Quelltabellenblatt
ZeileLetzte = .UsedRange.Row + .UsedRange.Rows.Count - 1
'Quelltabelle in neue Arbeitsmappe kopieren
.Copy
End With
'Musterdatei/-tabelle erstellen
Set wbMuster = ActiveWorkbook
Set wksMuster = wbMuster.Worksheets(1)
With wksMuster
'nicht benötigte Zeilen löschen
.Range(.Rows(AnzTitel + AnzZeilen + 1), .Rows(ZeileLetzte)).Delete
'Inhalte unterhalb Titelzeilen löschen
.Range(.Rows(AnzTitel + 1), .Rows(AnzTitel + AnzZeilen)).ClearContents
End With
iCount = 1 'Startwert für Zähler der Zieldateien
'Zeilen in Quellblatt abarbeiten
For ZeileQuelle = AnzTitel + 1 To ZeileLetzte Step AnzZeilen
'Anzeige für Statuszeile während Erstellung der Splittdateien
Application.StatusBar = "Splittdatei " & Format(iCount, "000") & " von " _
& Format(Application.WorksheetFunction.RoundUp((ZeileLetzte - AnzTitel) _
/ AnzZeilen, 0), "000") & " wird erstellt"
If ZeileQuelle + AnzZeilen >= ZeileLetzte Then
'letzte Splittdatei erstellen - Muster verwenden
Set wbZiel = wbMuster
Set wksZiel = wksMuster
'restliche Quelldatenzeilen kopieren
With wksQuelle
.Range(.Rows(ZeileQuelle), .Rows(ZeileLetzte)).Copy _
Destination:=wksZiel.Cells(AnzTitel + 1, 1)
End With
Else
'nächste Splittdatei erstellen - Muster kopieren
wksMuster.Copy
Set wbZiel = ActiveWorkbook
Set wksZiel = wbZiel.Worksheets(1)
'nächste Quelldatenzeilen kopieren
With wksQuelle
.Range(.Rows(ZeileQuelle), .Rows(ZeileQuelle + AnzZeilen - 1)).Copy _
Destination:=wksZiel.Cells(AnzTitel + 1, 1)
End With
End If
With wbZiel
'Zieldatei speichern
If Val(Left(Application.Version, 2)) >= 12 Then
'Excel-Version 2007 und neuer
'Prüfen der Dateinamenserweiterung der Quelldatei
If LCase(Right(wbQuelle.Name, 3)) = "xls" Then
'als Excelformat 97 bis 2003 (.xls)
.SaveAs FileName:=sPath & sDatei & Format(iCount, "-000"), _
FileFormat:=56 'xlExcel8
Else
'als Excel 2007 Arbeitsmappe ohne Makros (.xlsx)
.SaveAs FileName:=sPath & sDatei & Format(iCount, "-000"), _
FileFormat:=51 'xlOpenXMLWorkbook
End If
Else
'Excel-Version 2003 und älter
.SaveAs FileName:=sPath & sDatei & Format(iCount, "-000")
End If
'Zieldatei schliessen
.Close savechanges:=False
End With
iCount = iCount + 1
Next
'Anwendungseinstellungen zurücksetzen
With Application
.EnableEvents = True
.ScreenUpdating = True
.StatusBar = False
End With
'Abschlussmeldung
MsgBox "Datei: " & wbQuelle.Name & vbLf _
& "Blatt: " & wksQuelle.Name & vbLf _
& "wurde in " & iCount - 1 & " Dateien gesplittet.", _
vbInformation + vbOKOnly, "Tabellenblattdaten splitten"
End Sub