Visual Basic
Von: re-G, 22.3.2010 16:58 Uhr
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





  1. Antwort von re-G 1
    Re: Excel-Export in Textdatei mit UTF-8 kodierung
    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 < 0 Then utf16 = utf16 + 65536
            If utf16 < &H80 Then ' 1 Byte
                GetUTF8String = GetUTF8String & Chr(utf16)
            ElseIf utf16 < &H800 Then ' 2 Byte
                uc(1) = &H80 + (utf16 And &H3F) ' Least Significant 6 bits
                utf16 = utf16 \ &H40 ' Shift UTF16 number right 6 bits
                uc(0) = &HC0 + (utf16 And &H1F) ' Use 5 remaining bits
                GetUTF8String = GetUTF8String & Chr(uc(0)) & Chr(uc(1))
            Else ' 3 Byte
                uc(2) = &H80 + (utf16 And &H3F) ' Least Significant 6 bits
                utf16 = utf16 \ &H40 ' Shift UTF16 number right 6 bits
                uc(1) = &H80 + (utf16 And &H3F) ' Use next 6 bits
                utf16 = utf16 \ &H40 ' Shift UTF16 number right 6 bits again
                uc(0) = &HE0 + (utf16 And &HF) ' Use 4 remaining bits
                GetUTF8String = GetUTF8String & Chr(uc(0)) & Chr(uc(1)) & Chr(uc(2))
            End If
        Next
    End Function
    


    Gruß
    re-G
    • Antwort von Reinhard 0
      Re: Excel-Export in Textdatei mit UTF-8 kodierung
      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
      • Antwort von Thomas Ramel 0
        Re: Excel-Export in Textdatei mit UTF-8 kodierung
        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 -