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