Habe unter Verwendung anderer Suchbegriffe bei Google ein Makro gefunden und entsprechend meiner Wünsche anpassen können.
Falls jemand anderes etwas ähnliches sucht, folgt hier der Code:
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 ' 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
Dim blnAnfuehrungszeichen As Boolean ' Angabe ein Anführungszeichen verwendet werden sollen oder nicht
Dim strTrennzeichen As String ' Angabe des Trennzeichens
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
'
' 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 < 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
|