*. csv mit excel dateinamen speichern

Public Sub exceldateioeffnen()
Const LW = "F:\"
Const Pfad = "F:\_DATENUMSETZUNG\_EINGANG"
ChDrive LW
ChDir Pfad
Dim varRetVal As Variant
varRetVal = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel-Dateien (*.xls; *.xlsx), *.xls; *.xlsx", _
Title:="   Excel Datei (*.xls und *.xlsx) zum Öffnen auswählen")
If varRetVal = False Then Exit Sub
On Error Resume Next
Workbooks.Open FileName:=varRetVal
On Error GoTo 0
'   als *.csv in F:\_DATENUMSETZUNG\_SICHERUNG\_CSV\  sichern
'?  HIER SOLL ALS *.CSV GESICHERT WERDEN
'?  aber mit dem Dateinamen und Datum/Uhrzeit ?
'?  WIE ?
Dim Daten As Range
Dim Zeile As Range
Dim Zelle As Range
Dim s As String
Dim i As Integer
For i = 1 To ActiveWorkbook.Sheets.Count
Set Daten = ActiveSheet.UsedRange
Open "F:\_DATENUMSETZUNG\_SICHERUNG\_CSV\" & i & " .csv" _
For Output As #1
For Each Zeile In Daten.Rows
For Each Zelle In Zeile.Cells
s = s & CStr(Zelle.Text) & ";"
Next
Print #1, s
s = ""
Next
Close #1
Sheets(i).Activate
Next i
'   als *.csv in F:\_DATENUMSETZUNG\_CSV\  sichern
Dim Daten1 As Range
Dim Zeile1 As Range
Dim Zelle1 As Range
Dim s1 As String
Dim i1 As Integer
For i1 = 1 To ActiveWorkbook.Sheets.Count
Set Daten = ActiveSheet.UsedRange
Open "F:\_DATENUMSETZUNG\_CSV\" & i1 & " .csv" _
For Output As #1
For Each Zeile In Daten.Rows
For Each Zelle In Zeile.Cells
s1 = s1 & CStr(Zelle.Text) & ";"
Next
Print #1, s1
s1 = ""
Next
Close #1
Sheets(i1).Activate
Next i1
'   Arbeitsmappe sichern
'   als *.xls in F:\_DATENUMSETZUNG\_SICHERUNG\_XLS\  sichern
Dim s1_Datum As String
Dim s1_Zeit As String
s1_Datum = Date
s1_Zeit = Time
s1_Datum = Application.Substitute(s1_Datum, ".", "")
Dim sich As String
Const LW1 = "F:\"
Const Pfad1 = "F:\_DATENUMSETZUNG\_SICHERUNG\_XLS"
On Error GoTo Fehler
sich = ActiveWorkbook.Name
ChDrive LW1
ChDir Pfad1
ActiveWorkbook.SaveAs FileName:=sich & s1_Datum & Format(s1_Zeit, "hhmmss") & ".xls",  _
FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=True
'   Arbeitsmappe sichern
'   als *.xlsx in F:\_DATENUMSETZUNG\_SICHERUNG\_XLSX\  sichern
Dim s2_Datum As String
Dim s2_Zeit As String
s2_Datum = Date
s2_Zeit = Time
s2_Datum = Application.Substitute(s2_Datum, ".", "")
Const LW2 = "F:\"
Const Pfad2 = "F:\_DATENUMSETZUNG\_SICHERUNG\_XLSX"
On Error GoTo Fehler
ChDrive LW2
ChDir Pfad2
ActiveWorkbook.SaveAs FileName:=sich & s2_Datum & Format(s2_Zeit, "hhmmss") & ".xlsx",  _
FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=True
ActiveWorkbook.Close
Exit Sub
Fehler:
MsgBox _
"LAUFWERK / VERZEICHNIS NICHT GEFUNDEN !"
End Sub