Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Per VBA .csv Datei im UTF-8 Format speichern
#1
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?
Antworten Top
#2
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ß
Microsoft Excel Expert · Microsoft Most Valuable Professional (MVP) :: 2011-2019 & 2020-2022 :: 10 Awards
https://de.excel-translator.de/translator :: Online Excel-Formel-Übersetzer :: Funktionen :: Fehlerwerte :: Argumente :: Tabellenbezeichner
[-] Folgende(r) 1 Nutzer sagt Danke an maninweb für diesen Beitrag:
  • DeLaGhetto
Antworten Top
#3
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!
Antworten Top
#4
Hallo,

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

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

Gruß
Microsoft Excel Expert · Microsoft Most Valuable Professional (MVP) :: 2011-2019 & 2020-2022 :: 10 Awards
https://de.excel-translator.de/translator :: Online Excel-Formel-Übersetzer :: Funktionen :: Fehlerwerte :: Argumente :: Tabellenbezeichner
[-] Folgende(r) 1 Nutzer sagt Danke an maninweb für diesen Beitrag:
  • DeLaGhetto
Antworten Top
#5
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
Antworten Top
#6
Oder:


PHP-Code:
Sub M_snb()
  Range("A1:B40").Copy
    
  With GetObject
("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .GetFromClipboard
    c00 
Replace(.GetTextvbTab".")
  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 
Zum übersetzen von Excel Formeln:

http://dolf.trieschnigg.nl/excel/index.p...gids=en+de
Antworten Top
#7
Also bei mir kommt ein Fehler bei:

Code:
.GetFromClipboard
Antworten Top
#8
dann ist Range("A1:B40") leer.
Zum übersetzen von Excel Formeln:

http://dolf.trieschnigg.nl/excel/index.p...gids=en+de
Antworten Top
#9
Nein, ist nicht leer.
Allerdings sind die Zellen nicht als Text Formatiert. Wenn ich die als Text formatieren, dann funktioniert das Makro auch.

Danke
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste