utf8 export ohne BOM (anpassung)

Sub blaa()
Call SaveUTF8File(ActiveSheet.Name)
End Sub
Sub SaveUTF8File(ByVal WsName As String)
Dim fname As Variant
Dim myfilename As Variant
Dim strOrdner As String
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets(WsName)
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1)  "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
If strOrdner = "" Then
MsgBox ("Kein Ordner gewählt!")
Else
If MsgBox("Wirklich " & WsName & " TXT Datei erstellen ?", vbYesNo) = vbYes Then
myfilename = WsName & "_" & Format(Date, "DDMMYYYY")
fname = strOrdner & myfilename & ".txt"
If fname = False Then Exit Sub
Call SaveAsUTF8TXT(fname, ws)
End If
End If
End Sub
Sub SaveAsUTF8TXT(ByVal fname As String, ByVal wsa As Worksheet)
Dim hfile As Integer    ' Filehandle bzw. Dateinummer
Dim i As Long           ' Zähler über alle Zeilen
Dim j As Integer        ' Zähler über alle Spalten
Dim OneLine As String   ' Eine Zeile als String
Dim maxcol As Integer   ' max. Anzahl an Spalten
With wsa
hfile = FreeFile
maxcol = .Cells.SpecialCells(xlCellTypeLastCell).Column
Open fname For Output As #hfile
Print #hfile, Chr(&HEF); Chr(&HBB); Chr(&HBF);
For i = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row
OneLine = ""
For j = 1 To maxcol - 1
OneLine = OneLine & Replace(.Cells(i, j).Text, Chr(34), Chr(34)) & Chr(9)
Next
OneLine = OneLine & Replace(.Cells(i, j).Text, Chr(34), Chr(34)) & vbCrLf
Print #hfile, GetUTF8String(OneLine);
Next i
Close #hfile
End With
End Sub
' frei nach http://www.
_
vovisoft.com/unicode/UniFunctions.htm#ToUTF8
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