csv-Export
04.03.2023 12:10:10
wethlo448
Ich habe in einer Excel-Datei ein funktionierendes VBA-Makro, welches mir ein Tabellenblatt in eine csv-Datei exportiert. Funktioniert alles blendend. Der Übersichtlichkeit würde ich gerne in dem besagten Tabellenblatt Spaltenüberschriften vergeben, welche allerdings nicht in die csv-Datei geschrieben werden dürfen. Heißt: Das Makro soll genau das gleiche machen wie bisher, allerdings erst ab der zweiten Zeile. Da ich von VBA quasi keine Ahnung habe hoffe ich, dass mir hier jemand weiterhelfen kann.
Sub MCStudioExport()
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
strMappenpfad = ActiveWorkbook.FullName
'strMappenpfad = Replace(strMappenpfad, ".xlsx", ".csv")
strMappenpfad = Replace(strMappenpfad, ".xlsm", ".csv")
strDateiname = strMappenpfad 'InputBox("Wie soll die CSV-Datei heißen (inkl. Pfad)?", " _
CSV-Export", strMappenpfad)
If strDateiname = "" Then Exit Sub
strTrennzeichen = ";" 'InputBox("Welches Trennzeichen soll verwendet werden?", " _
CSV-Export", ";")
If strTrennzeichen = "" Then Exit Sub
Set Bereich = ActiveSheet.UsedRange
Open strDateiname For Output As #1
For Each Zeile In Bereich.Rows
For Each Zelle In Zeile.Cells
If Zelle.Value = 0 Then
If InStr(1, Zelle.Text, strTrennzeichen) > 0 Then
'Zellen, die ein Trennzeichen beinhalten in Anführungsstriche setzen
strTemp = strTemp & """" & CStr(Zelle.Text) & """" & strTrennzeichen
Else
strTemp = strTemp & CStr(Zelle.Text) & strTrennzeichen
End If
Else
If InStr(1, Zelle.Value, strTrennzeichen) > 0 Then
'Zellen, die ein Trennzeichen beinhalten in Anführungsstriche setzen
strTemp = strTemp & """" & CStr(Zelle.Value) & """" & strTrennzeichen
Else
strTemp = strTemp & CStr(Zelle.Value) & strTrennzeichen
End If
End If
Next
If Right(strTemp, 1) = strTrennzeichen Then strTemp = Left(strTemp, Len(strTemp) - 1)
If Len(strTemp) = (Bereich.Columns.Count - 1) Then
'nicht print
Else
Print #1, strTemp
End If
strTemp = ""
Next
Close #1
Set Bereich = Nothing
End Sub