Excel & VBA

Sub Range2CSV() Dim varPfad As Variant Dim strPfad As String, strText As String, strTemp As String Dim objZelle As Object Dim lngZeile As Long, lngI As Long, lngDnr As Long Dim intFrage As Integer If Workbooks.Count = 0 Then MsgBox "Keine Mappe offen.", vbOKOnly + vbInformation, "Keine Mappe" Exit Sub End If If ActiveSheet.Type <> -4167 Then MsgBox "Das aktive Blatt ist kein Tabellenblatt.", vbOKOnly + vbInformation, "Keine Tabelle" Exit Sub End If If Selection.Cells.Count = 1 Then MsgBox "Es ist kein Bereich markiert.", vbOKOnly + vbInformation, "Keine Markierung" Exit Sub End If varPfad = Application.GetSaveAsFilename("", "CSV-Dateien (*.csv), *.csv") If varPfad = False Then Exit Sub If Dir(varPfad) <> "" Then intFrage = MsgBox("Die Datei existiert bereits. Soll sie überschrieben werden?", vbYesNo + vbExclamation, "Datei existiert") If intFrage = vbNo Then MsgBox "Datei nicht erzeugt.", vbOKOnly + vbInformation, "Abbruch" Exit Sub End If End If strPfad = varPfad lngI = 0 strText = "" For Each objZelle In Selection lngI = lngI + 1 If lngI = 1 Then lngZeile = objZelle.Row If objZelle.Row = lngZeile Then strTemp = strTemp & objZelle.Text & ";" Else strTemp = Left(strTemp, Len(strTemp) - 1) strText = strText & strTemp & vbNewLine strTemp = objZelle.Text & ";" End If lngZeile = objZelle.Row Next strTemp = Left(strTemp, Len(strTemp) - 1) strText = strText & strTemp & vbNewLine lngDnr = FreeFile Open strPfad For Output As #lngDnr Print #lngDnr, strText Close #lngDnr MsgBox "Datei erzeugt.", vbOKOnly + vbInformation, "Fertig" End Sub

Download: range2csv.xlam