Nur befüllte Zellen in ein Textdokument kodiert als UTF-8 ohne BOM exportieren

[Blane]

Wehrtes Forum ich bräuchte noch mal eure Hilfe.
Nach langer suche im Internet bin ich wieder am Verzweifeln 
Mit folgendem VBA Skript:

Option Explicit

Sub XLStoTXT()
       Dim Zelle As Range, strSave As String, lngRow As Long, Bereich As Range
       Set Bereich = [A1:B30]      'Hier wird der Bereich definiert
       Const DateiName = "D:\Ddatei.txt" 'Pfad der txt Datei
       Open DateiName For Output As #1
       lngRow = 1
       For Each Zelle In Bereich
               If Zelle.Row <> lngRow Then
                    Print #1, Left(strSave, Len(strSave)-1)
                    strSave = ""
                    lngRow = Zelle.Row
               End If
               strSave = strSave & Zelle & Chr(9)
       Next
       Print #1, left(strSave,len(strSave)-1)
       Close 1
End Sub

exportiere ich einen von mir bestimmten Bereich in ein Textdokument. 
Problem Nummer 1:
Wenn einige Zellen des Bereiches nicht befüllt sind, sind im Textdokument an dieser Stelle Leerzeichen , damit kann unser System was die TXT Datei verarbeitet leider nicht umgehen. 
Problem Nummer 2:
Das Textdokument wird ANSI-Codier gespeichert, die TXT-Datei muss in UTF-8 ohne BOM kodiert sein

Meine Frage ist also, kann man mein Skript soweit anpassen/ändern, dass sowas wie ne abfrage stattfindet ob Zellen befüllt sind oder nicht und wenn ja, dann sollen die befüllten Zellen ein TXT-File was UTF-( ohne BOM kodiert ist gepeichert werden.

Ich danke euch schon mal im voraus.

LG

[Der Steuerfuzzi]

Hallo,

mW kann Excel von Haus aus kein UTF-8 schreiben. Du musst also Deine Zeichen in UTF-8 umwandeln und dann schreiben. Schau mal z. B. hier:
http://www.herber.de/forum/archiv/1356to..._UTF8.html

[Der Steuerfuzzi]

Hallo,

ich habe mal in meinem Archiv gesucht, da ich das Problem schoneinmal hatte und habe das damals so gelöst:

Code:

Function CP1252_UTF8(strInput As String) As String
Dim t As String
Dim i As Long
For i = 1 To Len(strInput)
    s = Mid(strInput, i, 1)
    Select Case Asc(s)
       Case 0 To 127
          t = s
       Case 160 To 191
          t = Chr(&HC2) & s
       Case 192 To 255
          t = Chr(&HC3) & Chr(Asc(s) - 64)
       Case 128
          t = Chr(&HE2) & Chr(&H82) & Chr(&HAC)
       Case 130
          t = Chr(&HE2) & Chr(&H80) & Chr(&H9A)
       Case 131
          t = Chr(&HC6) & Chr(&H92)
       Case 132
          t = Chr(&HE2) & Chr(&H80) & Chr(&H9E)
       Case 133
          t = Chr(&HE2) & Chr(&H80) & Chr(&HA6)
       Case 134 To 135
          t = Chr(&HE2) & Chr(&H80) & Chr(Asc(s) + 26)
       Case 136
          t = Chr(&HCB) & Chr(&H86)
       Case 137
          t = Chr(&HE2) & Chr(&H80) & Chr(&HB0)
       Case 138
          t = Chr(&HC5) & Chr(&HA0)
       Case 139
          t = Chr(&HE2) & Chr(&H80) & Chr(&HB9)
       Case 140
          t = Chr(&HC5) & Chr(&H92)
       Case 142
          t = Chr(&HC5) & Chr(&HBD)
       Case 145 To 146
          t = Chr(&HE2) & Chr(&H80) & Chr(Asc(s) + 7)
       Case 147 To 148
          t = Chr(&HE2) & Chr(&H80) & Chr(Asc(s) + 9)
       Case 149
          t = Chr(&HE2) & Chr(&H80) & Chr(&HA2)
       Case 150 To 151
          t = Chr(&HE2) & Chr(&H80) & Chr(Asc(s) - 3)
       Case 152
          t = Chr(&HCB) & Chr(&H9C)
       Case 153
          t = Chr(&HE2) & Chr(&H84) & Chr(&HA2)
       Case 154
          t = Chr(&HC5) & Chr(&HA1)
       Case 155
          t = Chr(&HE2) & Chr(&H80) & Chr(&HBA)
       Case 156
          t = Chr(&HC5) & Chr(&H93)
       Case 158
          t = Chr(&HC5) & Chr(&HBE)
       Case 159
          t = Chr(&HC5) & Chr(&HB8)
    End Select
Next
CP1252_UTF8 = t
End Function

Ich weiß allerdings nicht mehr wo der Code herkommt.

Du musst dann Deinen Text durch die Funkltion jagen und dann mit Binary schreiben.

Code:

Sub XLStoTXT()
       Dim Zelle As Range, strSave As String, lngRow As Long, Bereich As Range
       Set Bereich = [A1:B30]      'Hier wird der Bereich definiert
       Const DateiName = "D:\Ddatei.txt" 'Pfad der txt Datei
       Open DateiName For Binary As #1
       lngRow = 1
       For Each Zelle In Bereich
               If Zelle.Row <> lngRow Then
                    Print #1, CP1252_UTF8(Left(strSave, Len(strSave)-1))
                    strSave = ""
                    lngRow = Zelle.Row
               End If
               strSave = strSave & Zelle & Chr(9)
       Next
       Print #1, left(strSave,len(strSave)-1)
       Close 1
End Sub

[Blane]

Hallo Michael, danke dir für deine Antwort
Da ich so ziemlich gar keine Ahnung von VB hab, könntest du mir vielleicht helfen das umzusetzen?????
Oder zu mindestens erklären was genau dein Skript macht?

LG

[Der Steuerfuzzi]

Der von mir gepostete Code war eine unfertige Version, hiermit sollte es funktionieren:

Code:

Function CP1252_UTF8_2(strInput As String) As String
Dim t As String
Dim i As Long
For i = 1 To Len(strInput)
    s = Mid(strInput, i, 1)
    Select Case Asc(s)
       Case 0 To 127
          t = t & s
       Case 160 To 191
          t = t & Chr(&HC2) & s
       Case 192 To 255
          t = t & Chr(&HC3) & Chr(Asc(s) - 64)
       Case 128
          t = t & Chr(&HE2) & Chr(&H82) & Chr(&HAC)
       Case 130
          t = t & Chr(&HE2) & Chr(&H80) & Chr(&H9A)
       Case 131
          t = t & Chr(&HC6) & Chr(&H92)
       Case 132
          t = t & Chr(&HE2) & Chr(&H80) & Chr(&H9E)
       Case 133
          t = t & Chr(&HE2) & Chr(&H80) & Chr(&HA6)
       Case 134 To 135
          t = t & Chr(&HE2) & Chr(&H80) & Chr(Asc(s) + 26)
       Case 136
          t = t & Chr(&HCB) & Chr(&H86)
       Case 137
          t = t & Chr(&HE2) & Chr(&H80) & Chr(&HB0)
       Case 138
          t = t & Chr(&HC5) & Chr(&HA0)
       Case 139
          t = t & Chr(&HE2) & Chr(&H80) & Chr(&HB9)
       Case 140
          t = t & Chr(&HC5) & Chr(&H92)
       Case 142
          t = t & Chr(&HC5) & Chr(&HBD)
       Case 145 To 146
          t = t & Chr(&HE2) & Chr(&H80) & Chr(Asc(s) + 7)
       Case 147 To 148
          t = t & Chr(&HE2) & Chr(&H80) & Chr(Asc(s) + 9)
       Case 149
          t = t & Chr(&HE2) & Chr(&H80) & Chr(&HA2)
       Case 150 To 151
          t = t & Chr(&HE2) & Chr(&H80) & Chr(Asc(s) - 3)
       Case 152
          t = t & Chr(&HCB) & Chr(&H9C)
       Case 153
          t = t & Chr(&HE2) & Chr(&H84) & Chr(&HA2)
       Case 154
          t = t & Chr(&HC5) & Chr(&HA1)
       Case 155
          t = t & Chr(&HE2) & Chr(&H80) & Chr(&HBA)
       Case 156
          t = t & Chr(&HC5) & Chr(&H93)
       Case 158
          t = t & Chr(&HC5) & Chr(&HBE)
       Case 159
          t = t & Chr(&HC5) & Chr(&HB8)
    End Select
Next
CP1252_UTF8_2 = t
End Function

Dein Code angepasst:

Code:

Sub XLStoTXT()
       Dim Zelle As Range, strSave As String, lngRow As Long, Bereich As Range
       Set Bereich = [A1:B30]      'Hier wird der Bereich definiert
       Const DateiName = "D:\Ddatei.txt" 'Pfad der txt Datei
       Open DateiName For Binary As #1
       lngRow = 1
       For Each Zelle In Bereich
               If Zelle.Row <> lngRow Then
                    Put #1, CP1252_UTF8_2(Left(strSave, Len(strSave)-1))
                    strSave = ""
                    lngRow = Zelle.Row
               End If
               strSave = strSave & Zelle & Chr(9)
       Next
       Put #1, CP1252_UTF8_2(left(strSave,len(strSave)-1))
       Close 1
End Sub

Habe den Code nicht getestet, probier es mal aus. Eventuell solltest Du prüfen, ob eine Datei mit dem zu schreibenden Namen bereits existiert und diese vorher löschen, da dieser code die Datei zwar überschreibt, aber den bestehenden Inhalt nicht entfernt. d. h. wenn die zu schreibenden Daten weniger sind als die in der Datei, dann wird nur der erste Teil der Datei überschrieben und der Rest bleibt drin stehen.

[Blane]

Hi, Michael 
danke dir noch mal für die Hilfe, leider kommt beim ausführen ein Syntaxfehler beim Kompilieren.

LG

[snb]

Code:

Sub M_snb()
  for each it in [A1:B30].specialcells(2)
    c00=c00 & it & vblf
  next

  With CreateObject("ADODB.Stream")
    .Type = 2
    .Charset = "utf-8"
    .Open
    .writetext c00

    .SaveToFile "G:\OF\__UTF8_ADODB.txt", 2 
    .Close
  End With
End Sub

[Der Steuerfuzzi]

Hast Du die Codes in deine Datei kopiert?
Welche Meldung kommt genau?

[Blane]

@snb
bei deinem Code kommt auch ein Fehler beim Kompilieren: Variable nicht definiert und zeigt dann auf das "it" bei For Each it In [A1:B30].SpecialCells(2)

@Michael, also ich habe mein Macro komplett  ersetzt durch dein Code 
Die Meldung lautet: Fehler beim Kompilieren: Syntaxfehler  und es wird die Zeile markiert zwei mal markiert:
Put #1, CP1252_UTF8_2(Left(strSave, Len(strSave)-1))

[Der Steuerfuzzi]

Asche auf mein Haupt!    Ich habe ein Komma vergessen, so sollte es gehen:
Put #1, ,CP1252_UTF8_2(Left(strSave, Len(strSave)-1))