Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1116to1120
1116to1120
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Tabellen aufsplitten - Marko

Forumthread: Tabellen aufsplitten - Marko

Tabellen aufsplitten - Marko
bernie
Hallo Geimeinde,
ich bräuchte mal wieder Hilfe.
Aus einer Excel-Tabelle (diese hat 43.000 Zeilen) möchte ich ab der 2. Zeile die folgenden 500 Zeilen kopieren und in eine neue Tabelle einfügen. Diese sollte wiederum nummeriert abgespeichert werden (00001-00500 usw.)
Der Vorgang soll so lange wiederholte werden, bis alle 43.000 Zeilen in 500-er Blöcken ausgelesen und in neuen Dateien gespeichert sind.
Ich habe zwar eine Vorstellung vom Ablauf, bekomme aber die VBA-Programmierung nicht hin.
(Gelegentlich habe ich auch Tabelle mit weniger Zeilen, welche auf die gleiche Weise aufbereitet werden sollen).
Vielleich kann mir jemand helfen.
Bernie
Anzeige
geht es so.
18.11.2009 13:47:33
Tino
Hallo,
kannst ja mal testen ob es geht.
Sub test()
Dim iCalc As Integer
Dim Bereich As Range
Dim A As Long

With Sheets("Tabelle1") 'Tabelle1 'Tabelle angeben 
 Set Bereich = .UsedRange
End With

With Application
   iCalc = .Calculation
   .Calculation = xlCalculationManual
   .ScreenUpdating = False
   .EnableEvents = False
     For A = 2 To Bereich.Rows.Count Step 500
       With Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                Range(Bereich.Rows(A), Bereich.Rows(A + 499)).Copy .Range("B2")
                With .UsedRange.Columns(1).Offset(0, -1)
                 .FormulaR1C1 = "=ROW(RC)-1"
                 .NumberFormat = "000000"
                 .Value = .Value
                End With
       End With
     Next A
   .ScreenUpdating = True
   .EnableEvents = True
   .Calculation = iCalc
End With
End Sub
Gruß Tino
Anzeige
AW: Tabellen aufsplitten - Marko
18.11.2009 22:06:05
bernie
Hallo Tino,
wahrscheinlich hatte ich mich nicht richtig ausgedrückt.
Wie gesagt, habe ich eine Datei, darin eine Tabellenblatt mit 46.000 Datenzeilen. Die Daten sollen jeweils im 500-er Pack ausgelesen, in eine neue Datei -in ein dortiges Tabellenblatt- gestellt und dann die unter dem Namen 00001-01001 gespeichert werden.
Dieser Vorgang soll so lange wiederholt werden, bis alle 46.000 Datenzeilen im 500-er Pack jeweils in einer neuen Datei - mit fortlaufender Nummer - gespeichert sind.
Ich habe mal eine Beispielansicht angehängt. https://www.herber.de/bbs/user/66039.doc
Vielleicht kommst du - oder auch jemand anderer mit dem Problem klar.
Programmiertechnisch ist mir das schleierhaft.
Bernie
Anzeige
noch ein versuch...
18.11.2009 22:26:54
Tino
Hallo,
die Dateien werden im gleichen Ordner gespeichert.
Sub test()
Dim iCalc As Integer
Dim Bereich As Range
Dim A As Long
Dim strPath$
Dim oWB As Workbook, strSaveName As String
strPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")

With Sheets("Tabelle1") 'Tabelle1 'Tabelle angeben 
 Set Bereich = .UsedRange
End With

With Application
   iCalc = .Calculation
   .Calculation = xlCalculationManual
   .ScreenUpdating = False
   .EnableEvents = False
     For A = 2 To Bereich.Rows.Count Step 500
       Set oWB = Workbooks.Add(1)
       With oWB.Sheets(1)
          Range(Bereich.Rows(A), Bereich.Rows(A + 499)).Copy .Range("A1")
          strSaveName = Format(A - 1, "00000") & "-" & Format(A + 498, "00000") & ".xls"
          oWB.Close True, strPath & strSaveName
       End With
     Next A
   .ScreenUpdating = True
   .EnableEvents = True
   .Calculation = iCalc
End With
End Sub
Gruß Tino
Anzeige
AW: Tabellen aufsplitten - Marko
18.11.2009 22:34:59
bernie
Hallo tino,
das läuft super - wenn du mir jetzt noch zeigen könntest, wie ich die Spaltenbeschriftung (Überschriften) mit in jede Tabelle übernehmen kann - wäre ich Meilen weitergekommen.
Gruß Bernie
AW: Tabellen aufsplitten - Marko
18.11.2009 22:51:03
bernie
Hallo Tino,
das läuft super - wenn du mir jetzt noch zeigen könntest, wie ich die Spaltenbeschriftung (Überschriften) mit in jede Tabelle übernehmen kann - wäre ich Meilen weitergekommen.
Gruß Bernie
Anzeige
AW: Tabellen aufsplitten - Marko
18.11.2009 23:01:42
Tino
Hallo,
müsste so funktionieren.
Sub test()
Dim iCalc As Integer
Dim Bereich As Range
Dim A As Long
Dim strPath$
Dim oWB As Workbook, strSaveName As String
strPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")

With Sheets("Tabelle1") 'Tabelle1 'Tabelle angeben 
 Set Bereich = .UsedRange
End With

With Application
   iCalc = .Calculation
   .Calculation = xlCalculationManual
   .ScreenUpdating = False
   .EnableEvents = False
   .DisplayAlerts = False
     
     For A = 2 To Bereich.Rows.Count Step 500
       Set oWB = Workbooks.Add(1)
       With oWB.Sheets(1)
          Bereich.Rows(1).Copy .Range("A1")
          Range(Bereich.Rows(A), Bereich.Rows(A + 499)).Copy .Range("A2")
          strSaveName = Format(A - 1, "00000") & "-" & Format(A + 498, "00000") & ".xls"
          oWB.Close True, strPath & strSaveName
       End With
     Next A
   
   .DisplayAlerts = True
   .ScreenUpdating = True
   .EnableEvents = True
   .Calculation = iCalc
End With
End Sub
Gruß Tino
Anzeige
AW: Tabellen aufsplitten - Marko
19.11.2009 00:02:47
bernie
Hallo Tino,
das läuft super. I am happy.
Nur noch eine Frage: Wie speichere ich das Ganze im .csv Format?
Wenn ich hinter in der Zeile strSaveName .csv eingebe, bekomme ich nur Schrott.
Gruß Bernie
So...
19.11.2009 10:24:04
Björn
Hallo Tino,

strSaveName = Format(A - 1, "00000") & "-" & Format(A + 498, "00000") & ".csv"
oWB.SaveAs Filename:=strSaveName, FileFormat:=xlCSV  , CreateBackup:=False
oWB.Close False
so müsste das funitionieren.
Ich glaube nicht, dass Du direkt dem Close Befehl mitgeben kannst, dass als csv gespeichert werden soll, deswegen brauch ich dafür ne extra Zeile.
Vielleicht weiß jemand anders, ob das geht...
Gruß
Björn B.
Anzeige
Leider nicht
19.11.2009 13:01:16
bernie
Hallo Björn und Tino
den Vorschlag von Björn hatte ich bereits probiert. Das Abspeichern funktionierte zwar, allerdings brauche ich in den Daten die Trennzeichen Semikolon und nicht das Komma.
Und offensichtlich erkennt mein Excel 2003 den Ausdruck Delimiter nicht, denn sonst hätte ich das Trennzeichen dort hintenan stellen können.
Vielleicht klappts ja doch noch.
Trozdem mal Vorab besten Dank
Anzeige
Dann hast Du die falsche Frage gestellt.
19.11.2009 13:25:29
Björn
Hallo,
Das allerdings ist ein äußerst schwieriges Problem, was vor Dir auch noch keiner hatte ;-)
http://tinyurl.com/yhc8dpw
Das war nur 1 Versuch von mir. Andere Schlagworte finden bestimmt noch mehr Treffer.
Wie wäre es mit 
owB.SaveAs Filename:=strSaveName, FileFormat:=xlCSV, CreateBackup:=False, local:=True
Gruß
Björn B.
Anzeige
AW: Dann hast Du die falsche Frage gestellt.
19.11.2009 13:51:02
bernie
Hallo Leute
ganz herzlichen dank für die Unterstüzung - hat jetzt endlich geklappt.
Grüsse aus SW BW
Bernie
hier mein Vorschlag dazu.
19.11.2009 16:30:23
Tino
Hallo,
kannst mal testen.
Sub AenderCSVDelimiter(strFile As String, sDelimiter As String)
Dim F As Integer, AldDelimiter As String
Dim sInhalt As String
AldDelimiter = IIf(sDelimiter = ";", ",", ";")

If Dir$(strFile, vbNormal) <> "" Then
    F = FreeFile
    Open strFile For Binary As #F
    sInhalt = Space$(LOF(F))
    Get #F, , sInhalt
    Close
    
    sInhalt = Replace(sInhalt, AldDelimiter, sDelimiter)

    F = FreeFile
    Open strFile For Output As #F
    Print #F, sInhalt
    Close #F
End If
End Sub

Sub test()
Dim iCalc As Integer
Dim Bereich As Range
Dim A As Long
Dim strPath$
Dim oWB As Workbook, strSaveName As String, sDelimiter As String

strPath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
sDelimiter = InputBox("Geben Sie den CSV Trennzeichen an", Default:=";")
With Sheets("Tabelle1") 'Tabelle1 'Tabelle angeben 
 Set Bereich = .UsedRange
End With

With Application
   iCalc = .Calculation
   .Calculation = xlCalculationManual
   .ScreenUpdating = False
   .EnableEvents = False
   .DisplayAlerts = False
     
     For A = 2 To Bereich.Rows.Count Step 500
       Set oWB = Workbooks.Add(1)
       With oWB.Sheets(1)
          Bereich.Rows(1).Copy .Range("A1")
          Range(Bereich.Rows(A), Bereich.Rows(A + 499)).Copy .Range("A2")
          strSaveName = Format(A - 1, "00000") & "-" & Format(A + 498, "00000") & ".csv"
          oWB.SaveAs Filename:=strPath & strSaveName, FileFormat:=xlCSV, CreateBackup:=False
          oWB.Close False
          AenderCSVDelimiter strPath & strSaveName, sDelimiter
       End With
     Next A
   
   .DisplayAlerts = True
   .ScreenUpdating = True
   .EnableEvents = True
   .Calculation = iCalc
End With
End Sub
Gruß Tino
Anzeige
AW: hier mein Vorschlag dazu.
20.11.2009 14:05:36
bernie
Hallo Tino,
einfach genial - jetzt kann ich sogar die Trennzeichen wählen.
Nochmals ganz herzlichen Dank für die super Unterstützung.
Bernie
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige