[Makro] - als .csv abspeichern mit kyrillischen Buchstaben

[DeLaGhetto]

Hallo zusammen,

ich habe ein Makro, dass mir meine Excel Datei als .csv abspeichert.

Code:

Sub ExportToCSV()
    Dim lastRow As Long
    Dim csvFilePath As Variant
    Dim i As Long, j As Long
    Dim csvData As String
   
    ' Bestimme die letzte beschriebene Zelle in Spalte A
    lastRow = Sheets("Tabelle2").Cells(Sheets("Tabelle2").Rows.Count, "A").End(xlUp).Row
   
    ' Abfrage des Speicherorts für die CSV-Datei
    csvFilePath = Application.GetSaveAsFilename(InitialFileName:="Export.csv", FileFilter:="CSV-Dateien (*.csv), *.csv")
   
    ' Überprüfe, ob der Benutzer eine Datei ausgewählt hat
    If csvFilePath = "Falsch" Then
        MsgBox "Es wurde keine Datei ausgewählt. Der Export wurde abgebrochen.", vbExclamation
        Exit Sub
    End If
   
    ' Öffne die CSV-Datei zum Schreiben
    Open csvFilePath For Output As #1
   
    ' Schreibe Daten in die CSV-Datei
    For i = 1 To lastRow
        csvData = ""
        For j = 1 To 6 ' Spalten A bis F
            ' Behandlung kyrillischer Buchstaben in Spalte F
            If j = 6 Then
                csvData = csvData & Replace(Sheets("Tabelle2").Cells(i, j).Value, ChrW(1604), " ") ' Platzhalter ersetzen
            Else
                csvData = csvData & Sheets("Tabelle2").Cells(i, j).Value
            End If
            If j <> 6 Then csvData = csvData & "," ' Komma als Trennzeichen, außer für die letzte Spalte
        Next j
        Print #1, csvData ' Schreibe Datenzeile in die CSV-Datei
    Next i
   
    ' Schließe die CSV-Datei
    Close #1
   
    ' Konvertiere die CSV-Datei von ANSI in UTF-8
    KonvertANSI2UTF csvFilePath, "utf-8"
   
    MsgBox "CSV-Datei wurde erfolgreich exportiert und konvertiert.", vbInformation
End Sub

Sub KonvertANSI2UTF(ByVal filePath As String, ByVal encoding As String)
    Dim sText As String
   
    ' Dateiinhalt lesen
    Open filePath For Input As #1
    sText = Input$(LOF(1), 1)
    Close #1
   
    ' Schreiben der Daten in die neue UTF-Datei
    With CreateObject("ADODB.Stream")
        .Type = 2 ' Textmodus
        .Charset = encoding
        .Open
        .WriteText sText
        .SaveToFile Replace(filePath, ".csv", "_utf8.csv"), 2 ' UTF-8 speichern
        .Close
    End With
End Sub

In Spalte F habe ich allerdings Kyrillische Buchstaben.
Egal was ich mache, ich schaffe es einfach nicht diese Kyrillischen Buchstaben richtig zu formatieren. Es kommt immer als Ergebnis "???????? ??????" in der csv Datei.

Kann mir einer von euch helfen?

[HKindler]

Hi,

wieso verwendest du nicht einfach den Befehl "Speichern unter" und als Dateiformat dann "CSV UTF-8"?

Falls du es als Makro brauchst, kannst du den Vorgang auch mit dem Makrorekorder aufzeichnen.

[Ralf A]

Hi,

muss es unbedingt csv sein? Speichere sie als pdf. Wenn Du die Daten wieder nach Excel importieren willst, geht das mit PQ ganz easy und die kyrillischen Buchstaben bleiben kyrillisch

[DeLaGhetto]

Ich hab mir selber geholfen.
Vielleicht hilft es ja jemandem für die Zukunft:

Code:

Sub ExportToCSV_UTF8()
    Dim fsT As Object
    Dim csvFilePath As Variant
    Dim tmpStr As String
    Dim lRow As Long
    Dim lastRow As Long
    Dim SrcRg As Range
    Dim cellValue As String
   
    ' Pfad und Name der zu erstellenden Datei
    csvFilePath = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")
   
    ' Überprüfen, ob eine Auswahl getroffen wurde
    If Selection.Cells.Count > 1 Then
        Set SrcRg = Selection
    Else
        Set SrcRg = Sheets("Tabelle2").Range("A:F")
    End If
   
    ' Bestimme die letzte beschriebene Zelle in den Spalten A bis F
    lastRow = SrcRg.Find(What:="*", After:=SrcRg.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).row
   
    ' ADODB.Stream-Objekt erstellen und konfigurieren
    Set fsT = CreateObject("ADODB.Stream")
    fsT.Type = 2                ' Stream-Typ: Text/String
    fsT.Charset = "utf-8"       ' Zeichensatz
    fsT.Open                    ' Stream öffnen
   
    ' Daten in den temporären String tmpStr schreiben
    For lRow = 1 To lastRow
        tmpStr = ""
        For Each cell In SrcRg.Rows(lRow).Cells
            ' Zellinhalt in Textwert konvertieren und zu tmpStr hinzufügen
            cellValue = CStr(cell.Value)
            tmpStr = tmpStr & cellValue & ","
        Next cell
        ' Letztes Komma entfernen und Zeilenumbruch hinzufügen
        tmpStr = Left(tmpStr, Len(tmpStr) - 1) & vbCrLf
        fsT.WriteText tmpStr        ' Daten schreiben
    Next lRow
   
    ' Datei speichern und Stream schließen
    fsT.SaveToFile csvFilePath, 2 ' Datei speichern
    fsT.Close
   
End Sub