AW: Automatisch Zellen kopieren/Datei erstellen
16.11.2005 22:43:28
Erich
Hallo Sebastian,
einfacher als dir zu beschreiben, wie man das lösen könnte, war für mich die Anpassung eines Programms, das ich schon hatte. Du kannst es in ein normales Modul einer Arbeitsmappe kopieren:
Option Explicit
Sub Aufteil_XLS()
' Erich Gier, Kirchhoffstr. 13, 47475 Kamp-Lintfort, eri474_at_web.de
Dim wbQ As Workbook, wsQ As Worksheet, Sp As Range
Dim AnzQ&, ii%, jj%, zz1&, zz2&, MNam$, BNam$
' ######################################################### Vorgaben
Set wbQ = Workbooks("DEINEMAPPE.xls") ' Quellmappe (muss geöffnet sein)
Set wsQ = wbQ.Worksheets(1) ' oder ein anderes Blatt
Const AnzK = 0 ' 0 oder Anzahl Kopfzeilen (stehen in jeder Ausgabe)
Const AnzD = 2000 ' Anzahl Datenzeilen pro Ausgabe (unter Kopfzeilen)
Const NeuM = True ' Ausgabe in
' True: mehreren Mappen mit je einem Blatt
' False: mehreren Blättern einer neuen Mappe
Const SpBr = 1 ' Spaltenbreite der Ausgabe:
' 0: Standardbreite
' 1: wie Quelle
' 2: Autofit
' sonst: SpBr (wie hier vorgegeben)
' ######################################################### Vorgaben Ende
MNam = Left(wbQ.FullName, Len(wbQ.FullName) - 4) ' ohne .xls
BNam = wsQ.Name
Workbooks.Add xlWBATWorksheet
If NeuM Then
If AnzK Then wsQ.Rows(1 & ":" & AnzK).Copy Cells(1, 1)
If SpBr = 1 Or SpBr > 2 Then
For jj = 1 To wsQ.UsedRange.Columns.Count
Columns(jj).ColumnWidth = _
IIf(SpBr = 1, wsQ.Columns(jj).ColumnWidth, SpBr)
Next jj
End If
Else
MNam = MNam & "-Teile.xls"
End If
AnzQ = wsQ.Cells(Rows.Count, 1).End(xlUp).Row
zz1 = 1 + AnzK
Do
ii = ii + 1
If Not NeuM Then
If ii > 1 Then _
Worksheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = BNam & "_" & Format(ii, "000")
If AnzK Then wsQ.Rows(1 & ":" & AnzK).Copy Cells(1, 1)
If SpBr = 1 Or SpBr > 2 Then
For jj = 1 To wsQ.UsedRange.Columns.Count
Columns(jj).ColumnWidth = _
IIf(SpBr = 1, wsQ.Columns(jj).ColumnWidth, SpBr)
Next jj
End If
End If
zz2 = zz1 + AnzD - 1
If zz2 > AnzQ Then
zz2 = AnzQ
If NeuM And ii > 1 Then _
Rows(AnzQ + 1 - (ii - 1) * AnzD & ":" & AnzD + AnzK).Clear
End If
wsQ.Rows(zz1 & ":" & zz2).Copy Cells(1 + AnzK, 1)
If SpBr = 2 Then Columns.AutoFit
If NeuM Then _
ActiveWorkbook.SaveAs MNam & "_" & Format(ii, "000") & ".xls"
zz1 = ii * AnzD + 1 + AnzK
Loop Until zz1 > AnzQ
If Not NeuM Then ActiveWorkbook.SaveAs MNam
ActiveWorkbook.Close
End Sub
Im Abschnitt "Vorgaben" musst du noch den Namen deiner großen Mappe eintragen. Vor dem Start des Makros muss die große Mappe geöffnet sein.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort