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
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.
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
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
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