Excel-Export in Textdatei mit UTF-8 kodierung

Computer: Software & Programmierung Visual Basic
#1

Hallo zusammen.
Ich hoffe mal das Forum hier ist richtig, sonst bitte verschieben.

Ich versuche einzelne Spalten eines Excel-Arbeitsblattes un eine Datei zu exportieren. Mit dem bisherigen code funktioniert das ganz gut.
Leider muss die Textdatei UTF-8 kodiert sein.
Hat vielleicht einer eine Idee wie ich das bewerkstelligen kann?
Der vollständigkeit halbe hier mein bisheriger code:

Sub ExportC()
Dim fso
Dim arr()
Dim L As Long
Dim Zellen As Range
Dim TXTDatei
Dim Bereich As Range
Const Pfad = "C:/test/test.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
Set TXTDatei = fso.CreateTextFile(Pfad, True, True)
Set Bereich = Range("A1:A" & Range("A65536").End(xlUp).Row)
For Each Zellen In Bereich
ReDim Preserve arr(L)
 If Zellen "" Then
 arr(L) = Zellen
 L = L + 1
 End If
Next
With TXTDatei
 .WriteLine Join(arr, vbNewLine)
 .Close
End With

End Sub
#2

Ich versuche einzelne Spalten eines Excel-Arbeitsblattes un
eine Datei zu exportieren. Mit dem bisherigen code
funktioniert das ganz gut.
Leider muss die Textdatei UTF-8 kodiert sein.

Hallo re-g,

hier gibt es diesen Editor, der kann Utf-8 erstellen.

http://www.pspad.com/de/

Code von einem Button im Blatt starten.

Sub ExportC()
Dim MyData As New DataObject 'Verweis auf MS Forms 2.0 Object Library setzen
Dim Editor, Merker As String
Dim arr As Range
Dim Zelle As Range
Dim Bereich As Range
Merker = CurDir
ChDir "C:\test\2010"
Set MyData = New DataObject
Set Bereich = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
For Each Zelle In Bereich
 If Zelle "" Then
 If Not arr Is Nothing Then
 Set arr = Application.Union(arr, Zelle)
 Else
 Set arr = Zelle
 End If
 End If
Next
With Worksheets("Tabelle2")
 .Columns(1).ClearContents
 arr.Copy Destination:=.Range("A1")
 .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row).Copy
End With
ChDir Merker
Application.SendKeys "^v%fu{F12}"
Editor = Shell("C:\Programme\PSPad editor\PSPad.exe utf.txt", vbMaximizedFocus)
End Sub

Gruß
Reinhard

#3

Grüezi re-G

Ich versuche einzelne Spalten eines Excel-Arbeitsblattes un
eine Datei zu exportieren. Mit dem bisherigen code
funktioniert das ganz gut.
Leider muss die Textdatei UTF-8 kodiert sein.
Hat vielleicht einer eine Idee wie ich das bewerkstelligen
kann?

Dirakt aus Excel heraus kannst Du das vielleicht auch mit einem Streaming-Objekt tun. Die folgenden Zeilen mussst Du noch im Bereich anpassen, dann müsste das klappen:

Sub SaveCSV\_UTF8()
Dim fsT As Object
Dim A As Variant
Dim B() As String
Dim D() As String
Dim Z As Long
Dim s As Byte
Dim r As Long
Dim C As Byte

Const Path As String = "C:\Test\"
Const Filename As String = "Test2"
Const Extension As String = ".CSV"
Const Separator As String = ";"
Const Wrapper As String = """"

 'Here you can define your own Range, too
 A = ActiveSheet.UsedRange

 If Not IsEmpty(A) Then
 Z = UBound(A, 1)
 s = UBound(A, 2)
 ReDim D(Z - 1)
 For r = 1 To Z
 ReDim B(s - 1)
 For C = 1 To s
 If InStr(1, A(r, C), Separator) \> 0 Then
 'Rows whith cells including the Separator
 'put in Wrapper
 B(C - 1) = Wrapper & A(r, C) & Wrapper
 Else
 B(C - 1) = A(r, C)
 End If
 Next C
 D(r - 1) = Join(B(), Separator)
 Next r

 'Stream Object erzeugen
 Set fsT = CreateObject("ADODB.Stream")

 'Stream type definieren
 fsT.Type = 2

 'Zeichen-satz für die Quelldaten dafinieren
 fsT.Charset = "utf-8"

 'Stream öffnen und Daten binär ins Objekt schreiben
 fsT.Open
 fsT.writetext Join(D(), vbCrLf)

 'Daten speichern
 fsT.SaveToFile Path & Filename & Extension, 2
 'Objekt zerstören
 Set fsT = Nothing
 End If
End Sub

Mit freundlichen Grüssen

Thomas Ramel

  • MVP für MS-Excel -
#4

Erst mal:
Danke euch beiden für die Mühe.

Nach langem Suchen habe ich im Netz doch noch etwas gefunden.
Die Funktion macht mir aus einem ASCII-String einen UTF8-String.
Mit dieser funktioniert es.

Private Function GetUTF8String(s As String) As String
 Dim i As Integer ' Zähler über die einzelnen Zeichen des utf16-Strings
 Dim utf16 As Long, uc(2) As Byte

 GetUTF8String = ""
 For i = 1 To Len(s)
 utf16 = AscW(Mid(s, i, 1))
 If utf16 

Gruß
re-G