Hallo Forum,
Ich finde den Fehler nicht. Meine CSV Datei wird zwar gesplittet in der geöffneten Arbeitsmappe und es werden weitere Tabellen angelegt.
Es soll aber so sein:
1.CSV splitten in 200 Zeilen jeweils
2. Gesplittete Datei jeweils auf c:\export\mappe1.csv...mappe2.cvs usw. gespeichert werden.
Sub CsvMitSemikolonDelimiterGeteiltInNeueSheetsEinfuegen()
Dim wbkNeu As Workbook
Dim wksN As Excel.Worksheet
Dim wksDazu As Excel.Worksheet
Dim qtbN As Excel.QueryTable
Dim vntPathAndFileName As Variant
Dim lngLetzteZeile As Long
Dim lngZeile As Long
Dim lngZeilenProSheet As Long
lngZeilenProSheet = 200
vntPathAndFileName = Application.GetOpenFilename( _
FileFilter:="csv Files (*.csv), *.csv", _
Title:="Meine Dateien ", _
MultiSelect:=False)
If VarType(vntPathAndFileName) = vbBoolean Then
MsgBox "Abgebrochen!"
Exit Sub
End If
Set wbkNeu = Application.Workbooks.Add
Set wksN = wbkNeu.Worksheets(1)
Set qtbN = wksN.QueryTables.Add("TEXT;" & vntPathAndFileName, wksN.Cells(1, 1))
qtbN.FieldNames = True
qtbN.RowNumbers = False
qtbN.FillAdjacentFormulas = False
qtbN.PreserveFormatting = True
qtbN.RefreshOnFileOpen = False
qtbN.RefreshStyle = xlOverwriteCells
qtbN.SaveData = True
qtbN.AdjustColumnWidth = False
qtbN.RefreshPeriod = 0
qtbN.TextFilePromptOnRefresh = False
qtbN.TextFilePlatform = xlWindows
qtbN.TextFileStartRow = 1
qtbN.TextFileParseType = xlDelimited
qtbN.TextFileTextQualifier = xlTextQualifierNone
qtbN.TextFileTabDelimiter = False
qtbN.TextFileSemicolonDelimiter = True
qtbN.TextFileDecimalSeparator = ","
qtbN.TextFileCommaDelimiter = False
qtbN.TextFileSpaceDelimiter = False
qtbN.TextFileSemicolonDelimiter = True
qtbN.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
qtbN.Refresh BackgroundQuery:=False
qtbN.Delete
wksN.Columns.AutoFit
Do
lngLetzteZeile = wksN.Cells(wksN.Rows.Count, 1).End(xlUp).Row
If lngLetzteZeile <= lngZeilenProSheet Then Exit Do
Set wksDazu = wbkNeu.Worksheets.Add(Before:=wksN)
wksN.Rows(1).Copy Destination:=wksDazu.Rows(1)
wksN.Range(wksN.Rows(2), wksN.Rows(lngZeilenProSheet)).Cut Destination:=wksDazu.Cells(2, 1)
wksN.Range(wksN.Rows(2), wksN.Rows(lngZeilenProSheet)).Delete
Loop
End Sub
Hoffe es findet sich jemand der mir das ändern kann.
Grüße
Richard
|