Option Explicit
Sub Excel_ExportCSVAktuellesBlattTrennzeichenSemikolon()
->Das aktuelle Blatt der aktuellen Tabelle wird als CSV-Datei exportiert.
->Trennzeichen ist das Semikolon.
->Tritt auf dem Blatt ein Sekikolon auf, wird es beim Export durch das Wort
->Semikolon ersetzt
->
->Die CSV-Datei erhält den Namen der Ausgangsdatei, um _yyyymmdd_hhnnss erweitert,
->und .csv als Endung. Sie wird im Pfad der Ausgangsdatei gespeichert.
->
->Beim Export werden leere Zeilen mit exportiert
Dim wb As Workbook, ws As Worksheet
Dim sDateiname As String, sDateinameFull As String
Set wb = ActiveWorkbook
Set ws = ActiveSheet
sDateiname = wb.Name
sDateiname = Left(sDateiname, Len(sDateiname) - 4) & Format(Now(), _yyyymmdd_hhnnss) & .csv
sDateinameFull = wb.Path & Application.PathSeparator & sDateiname
Call CSVDateiSchreiben(ws, sDateinameFull)
AUFRAEUMEN:
Set wb = Nothing: Set ws = Nothing
End Sub
'**********************************************************************************
Function CSVDateiSchreiben(ws As Worksheet, sDateinameFull As String)
Dim DateiHandle As Integer
Dim lCols As Long, lRows As Long, lCol As Long, lRow As Long
Dim lLastRow As Long, lLastCol As Long, z As Long, sp As Long
Dim S As String, s2 As String, outputLine As String
->letzte beschriebe Zeile und Spalte finden
lCols = ws.UsedRange.Columns.Count + ws.UsedRange.Column - 1
lRows = ws.UsedRange.Rows.Count + ws.UsedRange.Row - 1
lLastCol = 0
For z = lRows To 1 Step -1
lCol = ws.Cells(z, lCols + 1).End(xlToLeft).Column
If lCol > lLastCol Then lLastCol = lCol
Next
lLastRow = 0
For sp = lLastCol To 1 Step -1
lRow = ws.Cells(lRows + 1, sp).End(xlUp).Row
If lRow > lLastRow Then lLastRow = lRow
Next
->Bereich von 1,1 bis lLastRow, lLastcol zeilenweise
->in Datei schreiben
->(ggf. Semikolon durch Text Semikolon ersetzen)
DateiHandle = FreeFile
Open sDateinameFull For Output As #DateiHandle
For z = 1 To lLastRow
outputLine =
For sp = 1 To lLastCol
S = ws.Cells(z, sp).Value
->führende normale/geschützte Leer abschneiden
Do While Mid(S, 1, 1) = Or Mid(S, 1, 1) = Chr(160)
S = Right(S, Len(S) - 1)
Loop
->folgende Leerzeichen abschneiden
Do While Mid(S, Len(S), 1) = Or Mid(S, Len(S), 1) = Chr(160)
S = Left(S, Len(S) - 1)
Loop
->ggf. Semikolon ersetzen
S = MyReplace(S, ;, Semikolon)
->Value durch Semikolon getrennt anfügen
If outputLine = Then outputLine = S Else outputLine = outputLine & ; & S
Next sp
->Tabs durch Leezeichen ersetzen
outputLine = MyReplace(outputLine, Chr(9), )
Print #DateiHandle, outputLine
Next z
Close #DateiHandle
End Function
'**********************************************************************************
'Funktion erst ab Excel 2000 vorhanden, daher Ersatzfunktion für EXCEL97
Private Function MyReplace(ByVal T As String, ByVal S As String, ByVal E As String) As String
Dim pos As Long
If T = Or S = Then MyReplace = : Exit Function
pos = 1
Do
pos = InStr(pos, T, S, 1)
If pos = 0 Then Exit Do
T = Left(T, pos - 1) & E & Right(T, Len(T) - pos - Len(S) + 1)
pos = pos + Len(E)
Loop
MyReplace = T
End Function
