CSV mit UTF-8 Codierung exportieren per VBA
13.07.2018 08:46:53
Oliver
ich habe mit Makrorekorder und etwas selbst angeeignetem VBA Wissen schon einige Makro´s für mich erfolgreich erstellt.
Habe nun aber eine Anwendung, die deutlich über meine Kenntnisse hinaus geht.
Auch intensive Recherche im Netz bringt mich nicht zum gewünschten Ziel.
Hoffe hier etwas Hilfe zu finden, die ich dann auch selbst so in meinen Code einbinden kann. Habe schon Tips bekommen wie: "da musst du in den Stream schreiben" usw.
Allerdings ist das leider schon zu schwierig für mich.
Ich habe eine XLS-Datei, die ich per Code zu CSV mit Hochkomma als Texttrenner wandle.
Ziel war eigentlich, die CSV dann auch gleich mit Kodierung UTF-8 ohne BOM zu exportieren.
Leider klappt das nicht. Die CSV liegt nach dem Export nur im ANSI Format vor.
Kann mir jemand einen direkt umsetzbaren Tip geben ?
Vielen, vielen Dank im Voraus.
Gruß Oliver
Hier mein momentaner Code:
Sub Excel_Zu_UTF8()
Call ÜbersetzungslisteÖffnen
Call ZeichenErsetzen
Call CSV_Speichern
End Sub
Sub ÜbersetzungslisteÖffnen()
On Error GoTo ErrorÖffnen
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Übersetzungsliste auswählen !"
.InitialFileName = "R:\0_Projekte_TID\Übersetzungsliste"
' .AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel files", "*.xls"
If .Show = -1 Then
For Each Ordnerpfad In .SelectedItems
fname1 = Ordnerpfad 'Zur weiteren verwendung
Next Ordnerpfad
End If
End With
Workbooks.Open Filename:=fname1
fname1 = ActiveWorkbook.Name
' Sheets("Maschinen Stückliste").Select
GoTo Ende
ErrorÖffnen: MsgBox ("Fehler: kann Datei nicht öffnen"), vbMsgBoxSetForeground
End
Ende:
End Sub
Sub ZeichenErsetzen()
Cells.Select
Range("A1003").Activate
Cells.Replace What:="''", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:= _
False
Range("A1").Select
End Sub
Sub CSV_Speichern()
Dim SrcRg As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim FName As Variant
FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")
ListSep = Application.International(xlListSeparator)
If Selection.Cells.Count > 1 Then
Set SrcRg = Selection
Else
Set SrcRg = ActiveSheet.UsedRange
End If
Open FName For Output As #1
For Each CurrRow In SrcRg.Rows
CurrTextStr = ìî
For Each CurrCell In CurrRow.Cells
' CurrTextStr = CurrTextStr & """" & CurrCell.Value & """" & ListSep
CurrTextStr = CurrTextStr & """" & CurrCell.Text & """" & ListSep
Next
While Right(CurrTextStr, 1) = ListSep
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
Print #1, CurrTextStr
Next
Close #1
Windows("Übersetzungsliste.xls").Close False
End Sub