Per VBA .csv Datei im UTF-8 Format speichern

[DeLaGhetto]

Hallo zusammen,

ich habe das unten stehende Makro das auch wunderbar funktioniert:

Code:

Sub mtrXportCSV()
Dim rngBereich As Range
Dim rngZeile As Range
Dim rngZelle As Range
Dim strTemp As String
Dim strDateiname As String
Dim lenString As Long

Const strPfad As String = "XXXX"
Const strErweiterung As String = ".csv"
Const strTrennzeichen As String = ";"
strDateiname = "Import"

    Set rngBereich = ActiveSheet.Range("A1:B40")
   
    Open strPfad & strDateiname & strErweiterung For Output As #1

    For Each rngZeile In rngBereich.Rows
        For Each rngZelle In rngZeile.Cells
            If IsEmpty(rngZelle) Then
                Exit For
            End If
            If InStr(1, rngZelle.Text, ";") > 0 Then
            'Zellen, die ein Semikolon beinhalten in Anführungsstriche setzen
                'strTemp = strTemp & """" & CStr(rngZelle.Text) & """" & strTrennzeichen
            Else
                strTemp = strTemp & CStr(rngZelle.Text) & strTrennzeichen
            End If
        Next
        If Len(strTemp) > 0 Then
        strTemp = Left(strTemp, Len(strTemp) - 1)
            Print #1, strTemp
        End If
        strTemp = ""
    Next

    Close #1
    Set rngBereich = Nothing
    MsgBox "Export fertig"
End Sub

Jetzt brauche ich eigentlich "nur" noch, dass mir das Makro die .csv Datei nicht als ANSI (momentan so) abspeichert, sondern im UTF-8 Format abspeichert.
Könnt ihr mir dabei helfen das obere Makro dahingehend zu optimieren?

[maninweb]

Hallo,

hier eine Variante per ADODB.Stream, aufbauend auf Deinen Code und die UTF8-Dateien mit BOM erzeugt ...

Code:

Sub mtrXportCSV()
 
  Dim rngBereich    As Range
  Dim rngZeile      As Range
  Dim rngZelle      As Range
  Dim strTemp      As String
  Dim strDateiname  As String
  Dim strData      As String
  Dim lenString    As Long
  Dim objStream    As Object
 
  Const strPfad As String = "D:\Downloads\"
  Const strErweiterung As String = ".csv"
  Const strTrennzeichen As String = ";"
 
  strDateiname = "Import"
 
  Set rngBereich = ActiveSheet.Range("A1:B40")
 
  For Each rngZeile In rngBereich.Rows
   
    For Each rngZelle In rngZeile.Cells
   
      If IsEmpty(rngZelle) Then
       
        Exit For
       
      End If
     
      If InStr(1, rngZelle.Text, ";") > 0 Then
'      Zellen, die ein Semikolon beinhalten in Anführungsstriche setzen
'      strTemp = strTemp & """" & CStr(rngZelle.Text) & """" & strTrennzeichen
       
      Else
       
        strTemp = strTemp & CStr(rngZelle.Text) & strTrennzeichen
     
      End If
   
    Next
   
    If Len(strTemp) > 0 Then
     
      strData = strData & IIf(Len(strData) > 0, vbCrLf, "") & _
                Left(strTemp, Len(strTemp) - 1)
     
    End If
   
    strTemp = ""
   
  Next
 
  If Len(strData) > 0 Then
 
    Set objStream = CreateObject("ADODB.Stream")
   
    If Not objStream Is Nothing Then
     
      objStream.Type = 2
      objStream.Charset = "utf-8"
     
      objStream.Open
      objStream.WriteText strData
      objStream.SaveToFile strPfad & strDateiname & strErweiterung, 2
     
      MsgBox "Export fertig"
     
    Else
     
      MsgBox "Stream konnte nicht erzeugt werden."
     
    End If
   
    Set objStream = Nothing
   
  Else
   
    MsgBox "Keine Daten."
   
  End If
 
  Set rngBereich = Nothing
 
End Sub

Gruß

[DeLaGhetto]

Wow, richtig gut.

Vielen Dank dir. Funktioniert perfekt!!

Jetzt ist mir nur noch eine letzte Sache aufgefallen (das liegt aber am Original Code):
Ist es möglich, dass jedes Komma, dass in der erstellten .csv Datei vorhanden ist durch einen Punkt ersetzt wird?

Auch hier nochmal vielen Dank schon im Voraus!

[maninweb]

Hallo,

versuche es mal wie folgt, indem Du die entsprechende Zeile ersetzt ...

Code:

objStream.WriteText Replace(strData, ",", ".")

Gruß

[DeLaGhetto]

Einfach zu gut. Ihr seid die Besten.
Hat perfekt funktioniert.

Vielen Dank für die super Hilfe.

Zur Info hier nun der neue Code, falls jemand das gleiche Problem haben sollte:

Code:

Sub mtrXportCSV()

  Dim rngBereich    As Range
  Dim rngZeile      As Range
  Dim rngZelle      As Range
  Dim strTemp      As String
  Dim strDateiname  As String
  Dim strData      As String
  Dim lenString    As Long
  Dim objStream    As Object

  Const strPfad As String = "Hier kommt der Pfad hin"
  Const strErweiterung As String = ".csv"
  Const strTrennzeichen As String = ";"

  strDateiname = "Import"

  Set rngBereich = ActiveSheet.Range("A1:B40")
  For Each rngZeile In rngBereich.Rows
    For Each rngZelle In rngZeile.Cells
      If IsEmpty(rngZelle) Then
        Exit For
      End If
      If InStr(1, rngZelle.Text, ";") > 0 Then
      Else
        strTemp = strTemp & CStr(rngZelle.Text) & strTrennzeichen
      End If
    Next
    If Len(strTemp) > 0 Then
      strData = strData & IIf(Len(strData) > 0, vbCrLf, "") & _
                Left(strTemp, Len(strTemp) - 1)
    End If
    strTemp = ""
   
  Next

  If Len(strData) > 0 Then
    Set objStream = CreateObject("ADODB.Stream")
    If Not objStream Is Nothing Then
      objStream.Type = 2
      objStream.Charset = "utf-8"
      objStream.Open
      objStream.WriteText Replace(strData, ",", ".")
      'objStream.WriteText strData
      objStream.SaveToFile strPfad & strDateiname & strErweiterung, 2
      MsgBox "Export fertig"
     
    Else
      MsgBox "Stream konnte nicht erzeugt werden."
     
    End If
    Set objStream = Nothing
  Else
    MsgBox "Keine Daten."
  End If
 
  Set rngBereich = Nothing

End Sub

[snb]

Oder:

PHP-Code:

Sub M_snb()
  Range("A1:B40").Copy
    
  With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .GetFromClipboard
    c00 = Replace(.GetText, vbTab, ".")
  End With

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

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


[DeLaGhetto]

Also bei mir kommt ein Fehler bei:

Code:

.GetFromClipboard

[snb]

dann ist Range("A1:B40") leer.

[DeLaGhetto]

Nein, ist nicht leer.
Allerdings sind die Zellen nicht als Text Formatiert. Wenn ich die als Text formatieren, dann funktioniert das Makro auch.

Danke