xl ist beim erstellen der csv oft störrisch, ich mach das meist so.
' **********************************************************************
' Modul: Modul5 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub konvertieren()
Dim strPath As String, strDir As String, strFile As String
Dim intDay As Integer
Dim lngCalc As Long
Dim bolSucceed As Boolean
Const cstrOutPut As String = "E:\Temp\Test\test.csv" '"C:\Test\test.csv" 'Ausgabedatei
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
strPath = "E:\Temp\test" '"C:\Users\JoRa\Desktop" 'Stammverzeichnis - Anpassen
strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
strDir = Format(Date, "yyyyMM") & "\" 'Monatsorder
For intDay = Day(Date) To 1
strFile = strPath & strDir & Format(DateSerial(Year(Date), Month(Date), intDay), "yyyyMMdd") & _
".txt"
If Dir(strFile, vbNormal) <> "" Then
Workbooks.OpenText FileName:=strFile, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, _
1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), _
TrailingMinusNumbers:=True
bolSucceed = saveRangeAsCSV(ActiveSheet.UsedRange, cstrOutPut) > -1
Exit For
End If
Next
If Not bolSucceed Then
MsgBox "Keine Datei gefunden!", vbInformation, "Hinweis"
Else
MsgBox "Die Datei '" & cstrOutPut & "' wurde erfolgreich erstellt!", vbInformation, "Hinweis"
End If
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'konvertieren'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
End Sub
Private Function saveRangeAsCSV(Target As Range, FileName As String, Optional Separator As String = ";") As Long
Dim rngRow As Range, rng As Range
Dim strTmp As String
Dim FF As Integer
saveRangeAsCSV = -1
On Error GoTo ErrExit
If Dir(FileName, vbNormal) <> "" Then Kill FileName
FF = FreeFile
Open FileName For Output As #FF
For Each rngRow In Target.Rows
strTmp = ""
For Each rng In rngRow.Cells
strTmp = strTmp & rng.Text & Separator
Next
strTmp = Left(strTmp, Len(strTmp) - 1)
Print #FF, strTmp
Next
saveRangeAsCSV = FF
ErrExit:
Close #FF
End Function