hier eine Variante
05.10.2014 12:06:15
Tino
Hallo,
hier mal eine Variante.
Bei "Const CSV_Delimiter$..." kannst du das Trennzeichen angeben.
Die Tabelle müsstest du evtl. im Code noch anpassen.
Die CSV wird im Ordner der Datei erstellt wo sich der Code befindet. (evtl. anpassen)
Der Name der Datei wird aus dem Datum im Format TT_MM_JJJJ erstellt. (evtl. anpassen)
Sub CSV_Export()
Dim ArData, ArTmp
Dim n&
Dim F%
Dim strLine$, sFilePath$
Dim MsgResult As VbMsgBoxResult
Const CSV_Delimiter$ = "," 'Trennzeichen
'Pfad zur Datei
sFilePath = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
'Name der Datei
sFilePath = sFilePath & Format(Now, "dd_mm_yy") & ".csv"
'evtl. vorhandene löschen?
If Dir$(sFilePath, vbNormal) <> "" Then
MsgResult = MsgBox("Datei bereits vorhanden!" & vbCr & _
"Ersetzen?", vbQuestion + vbYesNo)
If MsgResult = vbYes Then
Kill sFilePath
DoEvents
End If
Else 'nicht vorhanden
MsgResult = vbYes
End If
'Datenbereich
With Tabelle1 'Tabelle anpassen
'ab A1 bis zur letzten gefüllten Zeile, Referenz = Spalte 1
'Spaltenanzahl = .Resize(, 11) = bis Spalte K
ArData = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 11)
End With
If Ubound(ArData) = 1 Then 'kein Datenbereich
MsgBox "Kein Datenbereich vorhanden!", vbExclamation
Exit Sub
End If
'Startzeile
'ab Zeile 2, ohne Überschrift
n = Lbound(ArData) + 1
'wenn Datei neu o. nicht vorhanden ab Zeile 1 mit Überschrift
If MsgResult = vbYes Then n = Lbound(ArData)
'einzelne Zeile an Textdatei anhängen
F = FreeFile
Open sFilePath For Append As #F
'Zeilenweise durchlaufen
For n = n To Ubound(ArData)
ArTmp = Application.Index(ArData, n)
strLine = Join(ArTmp, CSV_Delimiter)
'Trennzeichen am ende löschen
Do While Right$(strLine, 1) = CSV_Delimiter
strLine = Left$(strLine, Len(strLine) - 1)
Loop
'in Textfile schreiben
Print #F, strLine
Next n
Close #F
MsgBox "Export der Daten abgeschlossen!", vbInformation
End Sub
Gruß Tino