Sub SaveUTF8File()
Dim strDateiname As Variant
Dim strMappenpfad As String
strMappenpfad = ActiveWorkbook.Path + "\" + Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) + ".csv"
strDateiname = Application.GetSaveAsFilename( _
InitialFileName:=strMappenpfad, _
FileFilter:="CSV (*.csv), *.csv", _
Title:="Export CSV")
If strDateiname = False Then Exit Sub
SaveAsUTF8CSV (strDateiname)
End Sub
Sub SaveAsUTF8CSV(strDateiname As String)
Dim hfile As Integer
Dim i As Long
Dim j As Integer
Dim OneLine As String
Dim maxcol As Integer
Dim blnAnfuehrungszeichen As Boolean
Dim strTrennzeichen As String
strTrennzeichen = InputBox("Welches Trennzeichen soll verwendet werden?", "CSV-Export", ",")
If strTrennzeichen = "" Then Exit Sub
If MsgBox("Sollen die Werte in Anführungszeichen exportiert werden?", vbQuestion + vbYesNo, "CSV-Export") = vbYes Then
blnAnfuehrungszeichen = True
Else
blnAnfuehrungszeichen = False
End If
hfile = FreeFile
maxcol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
Open strDateiname For Output As #hfile
Print #hfile, Chr(&HEF); Chr(&HBB); Chr(&HBF);
For i = 1 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
OneLine = ""
For j = 1 To maxcol - 1
If blnAnfuehrungszeichen = True Then
OneLine = OneLine & Chr(34) & Cells(i, j).Text & Chr(34) & strTrennzeichen
Else
OneLine = OneLine & Cells(i, j).Text & strTrennzeichen
End If
Next j
If blnAnfuehrungszeichen = True Then
OneLine = OneLine & Chr(34) & Cells(i, j).Text & Chr(34) & vbCrLf
Else
OneLine = OneLine & Cells(i, j).Text & vbCrLf
End If
Print #hfile, GetUTF8String(OneLine);
Next i
Close #hfile
MsgBox "Export erfolgreich. Datei wurde exportiert nach" & vbCrLf & strDateiname
End Sub
Private Function GetUTF8String(s As String) As String
Dim i As Integer
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
GetUTF8String = GetUTF8String & Chr(utf16)
ElseIf utf16 < &H800 Then
uc(1) = &H80 + (utf16 And &H3F)
utf16 = utf16 \ &H40
uc(0) = &HC0 + (utf16 And &H1F)
GetUTF8String = GetUTF8String & Chr(uc(0)) & Chr(uc(1))
Else
uc(2) = &H80 + (utf16 And &H3F)
utf16 = utf16 \ &H40
uc(1) = &H80 + (utf16 And &H3F)
utf16 = utf16 \ &H40
uc(0) = &HE0 + (utf16 And &HF)
GetUTF8String = GetUTF8String & Chr(uc(0)) & Chr(uc(1)) & Chr(uc(2))
End If
Next
End Function