Option Explicit
Sub AktuelleDateiAlsCSVSpeichern()
Dim wb As Workbook, ws As Worksheet
Dim sPfad As String
Dim sDateiname As String, sDateinameOhneEndung As String, sEndung As String
Dim pos As Long, poslast As Long
Set wb = ActiveWorkbook
->ist mehr als ein Blatt in der Mappe enthalten
If wb.Sheets.Count > 1 Then
MsgBox _
Datei kann nicht als csv-Datei gespeichert werden, & vbLf & _
da mehr als ein Blatt enthalten ist.
GoTo AUFRAEUMEN
End If
->ist das Blatt ein Arbeitsblatt ?
If wb.Worksheets.Count <> 1 Then
MsgBox Blatt ist kein Arbeitsblatt.
GoTo AUFRAEUMEN
End If
->Makro-Datei ist nicht Datei ?
If wb.Name = ThisWorkbook.Name Then
MsgBox Makro-Datei kann Makro nicht auf sich selbst ausführen.
GoTo AUFRAEUMEN
End If
->Dateiinhalt ist gespeichert
If Not wb.Saved Then
sPfad = wb.Path
sDateiname = wb.Name
poslast = 0
pos = InStr(1, sDateiname, .)
Do
If pos = 0 Then Exit Do
poslast = pos
pos = InStr(pos + 1, sDateiname, .)
Loop
If poslast = 0 Then
sEndung =
sDateinameOhneEndung = sDateiname
Else
sEndung = Right(sDateiname, Len(sDateiname) - poslast)
sDateinameOhneEndung = Left(sDateiname, poslast - 1)
End If
->Datei ist nicht schon csv-Datei ?
If LCase(sEndung) = csv Then
MsgBox Datei ist bereits csv-Datei
GoTo AUFRAEUMEN
End If
->Dateiinhalt nicht gespeichert ?
If Not wb.Saved Then
MsgBox _
Die Datei enthält Änderungen, die noch nicht gespeichert sind. & vbLf & _
Bitte vorher speichern.
GoTo AUFRAEUMEN
End If
->Datei als Csv-Datei mit gleichem Namen und als in.csv speichern
Application.DisplayAlerts = False
wb.SaveAs _
Filename:=sPfad & Application.PathSeparator & sDateinameOhneEndung & 1 & .csv, _
FileFormat:=xlCSVWindows->xlCSVMSDOS, xlCSV
wb.SaveAs _
Filename:=sPfad & Application.PathSeparator & in & 2 & .csv, _
FileFormat:=xlCSVMSDOS
Application.DisplayAlerts = True
wb.Close Savechanges:=False
->ursprüngliche Datei öffnen
Set wb = Workbooks.Open(Filename:=sPfad & Application.PathSeparator & sDateiname)
AUFRAEUMEN:
Set wb = Nothing: Set ws = Nothing
End Sub
