noch eine Variante mit StrConv()
13.09.2017 12:23:38
Tino
Hallo,
hier noch eine Variante, kannst ja mal testen!
StrConv(), siehe auch hier wegen Version!
https://msdn.microsoft.com/de-de/library/office/gg264628.aspx
Sollte dies nicht gehen.
deaktiviere/lösche diese Zeile
sAusgabe = StrConv(sText & vbCrLf, vbUnicode)
und aktiviere diese Zeile
sAusgabe = ConvertToUnicode(sText & vbCrLf)
Sub Speichern_CSV_Spezial()
Dim SavePath$
On Error GoTo ErrorHandler:
'Pfad wo gespeichert werden soll
SavePath = ThisWorkbook.Path
SavePath = SavePath & IIf(Right$(SavePath, 1) = "\", "", "\")
'Speichern
'Tabelle, Pfad + Dateiname, Optional Trennzeichen Standard = ";"
Call SaveCSV(Tabelle1, SavePath & Tabelle1.Name & ".csv")
'' evtl. weitere Tabelle
'Call SaveCSV(Tabelle2, SavePath & Tabelle2.Name & ".csv")
ErrorHandler:
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "Fehler: " & Err.Number
End If
End Sub
Sub SaveCSV(objTabelle As Worksheet, strPath$, Optional Trennzeichen$ = ";")
Dim F%, sText$, sAusgabe$, n&, varArray
Dim FSO As Object, F1 As Object
On Error GoTo ErrorH:
With objTabelle.UsedRange
If .Rows.Count > 1 Or .Columns.Count > 1 Then
varArray = .Value
Else
If .Cells(1, 1) <> "" Then
varArray = .Cells(1, 1).Resize(, 2)
Redim Preserve varArray(1 To 1, 1 To 1)
Else
MsgBox "Tabelle entält keine Daten!"
End If
End If
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strPath) Then
Set F1 = FSO.GetFile(strPath)
If MsgBox("Datei '" & F1.Name & "' ist bereits vorhanden!" & vbCr & _
"Soll diese gelöscht werden?", vbQuestion + vbYesNo) = vbYes Then
F1.Delete
End If
Set F1 = Nothing
End If
Set FSO = Nothing
F = FreeFile
Open strPath For Output As #F
Print #F, Chr(255); Chr(254);
With Application
For n = 1 To Ubound(varArray)
sText = Join(.Index(varArray, n), Trennzeichen)
sAusgabe = StrConv(sText & vbCrLf, vbUnicode)
'' sollte StrConv nicht funktionieren *******
'sAusgabe = ConvertToUnicode(sText & vbCrLf)
'' ******************************************
Print #F, sAusgabe;
sAusgabe = ""
Next
End With
Close #F
Exit Sub
ErrorH:
If F <> 0 Then Close #F
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "Fehler: " & Err.Number
End If
End Sub
Function ConvertToUnicode(sText$)
Dim n&
For n = 1 To LenB(sText)
ConvertToUnicode = ConvertToUnicode & Chr(AscB(MidB$(sText, n, 1)))
Next
End Function
Gruß Tino