Hallo,

ich benötige ein Makro zum Exportieren einer CSV-Datei.
Das Makro soll folgende Funktionen haben:

- Trennzeichen = Komma
- Texterkennungszeichen = Anführungszeichen
- Ausgabepfad = Wird basierend auf dem Pfad der Excel Datei vorgeschlagen

Dazu habe ich bereits einige Makros im Internet gefunden, aber keins welche alle Anforderungen erfüllen. Mein Versuch ist anzupassen ist leider gescheitert.

Dieses Makro kann alles, außer die Kodierung in UTF 8:

Sub ExportCSV()
 
Dim Bereich As Object, Zeile As Object, Zelle As Object
Dim strTemp As String
Dim strDateiname As String
Dim strTrennzeichen As String
Dim strMappenpfad As String
Dim blnAnfuehrungszeichen As Boolean
 
strMappenpfad = ActiveWorkbook.Path + "\" + Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) + ".csv"
 
strDateiname = InputBox("Bitte den Namen der CSV-Datei angeben.", "CSV-Export", strMappenpfad)
If strDateiname = "" Then Exit Sub
 
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
 
Set Bereich = ActiveSheet.UsedRange
 
Open strDateiname For Output As #1
 
For Each Zeile In Bereich.Rows
    For Each Zelle In Zeile.Cells
        If blnAnfuehrungszeichen = True Then
            strTemp = strTemp & """" & CStr(Zelle.Text) & """" & strTrennzeichen
        Else
            strTemp = strTemp & CStr(Zelle.Text) & strTrennzeichen
        End If
    Next
    If Right(strTemp, 1) = strTrennzeichen Then strTemp = Left(strTemp, Len(strTemp) - 1)
    Print #1, strTemp
    strTemp = ""
Next
 
  Close #1
  Set Bereich = Nothing
  MsgBox "Export erfolgreich. Datei wurde exportiert nach" & vbCrLf & strDateiname
 
End Sub

Das folgende Makro kann UTF8, Komma als Trennzeichen, aber leider keine Anführungszeichen als Texterkennungszeichen.

Option Explicit

Private Declare Function WideCharToMultiByte Lib "kernel32.dll" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As Long, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As Long, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long) As Long

Private Const CP_UTF8 As Long = 65001


Public Sub UTF8_Main()
   
    Dim strText As String
    Dim objRange As Range
    Dim strMappenpfad As String
    Dim strDateiname As String
   
    strMappenpfad = ActiveWorkbook.Path + "\" + Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) + ".csv"
    strDateiname = InputBox("Bitte den Namen der CSV-Datei angeben.", "CSV-Export", strMappenpfad)
   
    If Get_Range(objRange) Then
   
        If Build_Output_String(objRange, strText) Then
       
            If Create_UTF8_File(strDateiname, strText) Then
           
                MsgBox "Erstellen der Datei erfolgreich beendet.", _
                    vbInformation, "Information"
           
            End If
        End If
    End If
End Sub

Private Function Get_Range(objRange As Range) As Boolean

    Dim lngRow As Long, lngColumn As Long
    Dim lngFirstRow As Long, lngFirstColumn As Long
    Dim lngLastRow As Long, lngLastColumn As Long
    Dim objLastUsedCell As Range
   
    On Error GoTo error_handler
   
    Set objLastUsedCell = Cells.SpecialCells(xlCellTypeLastCell)
   
    For lngRow = objLastUsedCell.Row To 1 Step -1
        If WorksheetFunction.CountBlank(Rows(lngRow)) < Columns.Count Then Exit For
    Next
    lngLastRow = lngRow
   
    For lngRow = 1 To objLastUsedCell.Row
        If WorksheetFunction.CountBlank(Rows(lngRow)) < Columns.Count Then Exit For
    Next
    lngFirstRow = lngRow
   
    For lngColumn = objLastUsedCell.Column To 1 Step -1
        If WorksheetFunction.CountBlank(Columns(lngColumn)) < Rows.Count Then Exit For
    Next
    lngLastColumn = lngColumn
   
    For lngColumn = 1 To objLastUsedCell.Column
        If WorksheetFunction.CountBlank(Columns(lngColumn)) < Rows.Count Then Exit For
    Next
    lngFirstColumn = lngColumn
   
    Set objRange = Range(Cells(lngFirstRow, lngFirstColumn), _
        Cells(lngLastRow, lngLastColumn))
   
    Get_Range = True
   
    Exit Function

error_handler:

    MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler in Prozedur ''Get_Range''"
       
End Function

Private Function Build_Output_String(objRange As Range, strText As String) As Boolean

    Dim lngRow As Long
    Dim vntTempArray As Variant
   
    On Error GoTo error_handler
   
    With objRange
   
        For lngRow = 1 To .Rows.Count
       
            vntTempArray = .Rows(lngRow).Value
           
            vntTempArray = WorksheetFunction.Transpose( _
                WorksheetFunction.Transpose(vntTempArray))
           
            strText = strText & Join(vntTempArray, ",") & vbCrLf
       
        Next
    End With
   
    strText = Left$(strText, Len(strText) - 2)
   
    Build_Output_String = True
   
    Exit Function

error_handler:

    MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler in Prozedur ''Build_Output_String''"
       
End Function

Private Function Create_UTF8_File(strFileName As String, strText As String) As Boolean

    Dim intFileNumber As Integer
    Dim bytBuffer() As Byte
    Dim lngLength As Long, lngPointer As Long, lngSize As Long

    On Error GoTo error_handler

    lngLength = Len(strText)
    lngPointer = StrPtr(strText)

    lngSize = WideCharToMultiByte(CP_UTF8, 0&, _
        lngPointer, lngLength, 0&, 0&, 0&, 0&)

    ReDim bytBuffer(0 To lngSize - 1)

    Call WideCharToMultiByte(CP_UTF8, 0&, lngPointer, _
        lngLength, VarPtr(bytBuffer(0)), lngSize, 0&, 0&)

    If Dir$(strFileName) <> vbNullString Then Call Kill(strFileName)
   
    Reset
    intFileNumber = FreeFile

    Open strFileName For Binary Access Write As #intFileNumber
    Put #intFileNumber, , bytBuffer
    Close #intFileNumber

    Create_UTF8_File = True
   
    Exit Function

error_handler:

    MsgBox "Fehler: " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, vbCritical, "Fehler in Prozedur ''Create_UTF8_File''"
     
End Function

Kann mir einer helfen und eins der beiden Makros entsprechend anpassen?

Gruß

Robert