Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
696to700
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
696to700
696to700
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Automatisch Zellen kopieren/Datei erstellen

Automatisch Zellen kopieren/Datei erstellen
16.11.2005 11:01:09
Sebastian
Hallo zusammen,
ich hab mal ne Fräge...
und zwar habe ich eine Excel Datei mit genau 60000 Einträgen.
Diese Einträge bestehen jeweils aus 8 Zahlen und die 60000 Einträge
stehen alle untereinander! Also nur in Spalte A... und immer abwärts!
Nun möchte ich aus dieser "großen" Exceldatei mehrere kleine machen,
sprich: Ich will z.B. ein Makro programmieren, dass ich auch
auf andere Dateien anwenden kann, wo er mir die 60000 Einträge in
in 2000 Schritten aufteilt und für jeweils 2000 Einträge immer eine
Datei mit fortlaufendem Namen erzeugt!
Die "große" 60000 Einträge starke Datei sollte aber bestehen bleiben!?
Was könnte man da machen? Hab leider nicht so viel Erfahrung im
VBA porgrammieren und da wollte ich mal fragen wie Ihr vorgehen würdet,
oder wie man das lösen könnte!?
Würd mich sehr über Hilfe freuen!!!
Gruß
Basti

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
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
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige