Sub Uebertragen()
Dim dateiname As String
Dim pfad As String
Dim ImportDatei As Variant
Dim wbImport As Workbook
Dim DatEingabe As String
dateiname = "Datenpunkte_" & Selection
dateiname = WorksheetFunction.Substitute(dateiname, ": ", "_")
dateiname = WorksheetFunction.Substitute(dateiname, " ", "_")
dateiname = WorksheetFunction.Substitute(dateiname, ".", "-")
dateiname = WorksheetFunction.Substitute(dateiname, Chr(10), "_")
MsgBox ("Bitte wählen Sie die Format-Datei (.csv) aus!")
ImportDatei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.csv), *.csv", Title:="Bitte wählen Sie eine Datei aus.")
If ImportDatei = False Then End
Dim ws As Worksheet, fd As FileDialog, rngTest As Range, rngExport As Range, fltr As FileDialogFilter
Set ws = Worksheets(3)
Set rngTest = ws.Range("E1")
Set rngExport = ws.Range("E2:E138")
If rngTest.Text <> "" Then
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.Title = "Zielort festlegen."
For I = 1 To .Filters.Count
If .Filters(I).Extensions = "*.csv" Then
.FilterIndex = I
Exit For
End If
Next
MsgBox ("Bitte wählen Sie einen Speicherort aus!")
.InitialFileName = dateiname
If .Show = True Then
ExportRangeAsCSV rngExport, ";", .SelectedItems(1)
End If
End With
End If
End Sub
Sub ExportRangeAsCSV(ByVal rng As Range, delim As String, filepath As String)
Dim arr As Variant, line As String, csvContent As String, fso As Object, csvFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set csvFile = fso.OpenTextFile(filepath, 2, True)
arr = rng.Value
If IsArray(arr) Then
For r = 1 To UBound(arr, 1)
line = ""
For c = 1 To UBound(arr, 2)
If c < UBound(arr, 2) Then
line = line & """" & arr(r, c) & """" & delim
Else
line = line & """" & arr(r, c) & """"
End If
Next
csvContent = csvContent & line & vbNewLine
Next
csvFile.Write (csvContent)
csvFile.Close
Else
MsgBox "Bereich besteht nur aus einer Zelle!", vbExclamation
End If
Set fso = Nothing
Set csvFile = Nothing
End Sub