Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen

Tabellen aufsplitten - Marko | Herbers Excel-Forum


Betrifft: Tabellen aufsplitten - Marko von: bernie
Geschrieben am: 18.11.2009 11:22:20

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

  

Betrifft: geht es so. von: Tino
Geschrieben am: 18.11.2009 13:47:33

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


  

Betrifft: AW: Tabellen aufsplitten - Marko von: bernie
Geschrieben am: 18.11.2009 22:06:05

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


  

Betrifft: noch ein versuch... von: Tino
Geschrieben am: 18.11.2009 22:26:54

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


  

Betrifft: AW: Tabellen aufsplitten - Marko von: bernie
Geschrieben am: 18.11.2009 22:34:59

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


  

Betrifft: AW: Tabellen aufsplitten - Marko von: bernie
Geschrieben am: 18.11.2009 22:51:03

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


  

Betrifft: AW: Tabellen aufsplitten - Marko von: Tino
Geschrieben am: 18.11.2009 23:01:42

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


  

Betrifft: AW: Tabellen aufsplitten - Marko von: bernie
Geschrieben am: 19.11.2009 00:02:47

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


  

Betrifft: So... von: Björn B.
Geschrieben am: 19.11.2009 10:24:04

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.


  

Betrifft: Leider nicht von: bernie
Geschrieben am: 19.11.2009 13:01:16

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


  

Betrifft: Dann hast Du die falsche Frage gestellt. von: Björn B.
Geschrieben am: 19.11.2009 13:25:29

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.


  

Betrifft: AW: Dann hast Du die falsche Frage gestellt. von: bernie
Geschrieben am: 19.11.2009 13:51:02

Hallo Leute

ganz herzlichen dank für die Unterstüzung - hat jetzt endlich geklappt.

Grüsse aus SW BW

Bernie


  

Betrifft: hier mein Vorschlag dazu. von: Tino
Geschrieben am: 19.11.2009 16:30:23

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


  

Betrifft: AW: hier mein Vorschlag dazu. von: bernie
Geschrieben am: 20.11.2009 14:05:36

Hallo Tino,

einfach genial - jetzt kann ich sogar die Trennzeichen wählen.
Nochmals ganz herzlichen Dank für die super Unterstützung.

Bernie


Beiträge aus den Excel-Beispielen zum Thema "Tabellen aufsplitten - Marko"