Vielen Dank
Sub SaveAsTxt()
Dim strSep As String, strDat As String, _
iCol As Byte, iRow As Integer, _
iR As Integer, iC As Byte, strTxt As String, _
strMldg As String, strTmp As String
If ActiveSheet Is Nothing Then Exit Sub
With ActiveSheet.UsedRange
iRow = .Rows.Count
iCol = .Columns.Count
End With
strSep = InputBox("Trennzeichen?")
If strSep = "" Then Exit Sub
Select Case strSep
Case "chr(9)", "tab", "Tab": strSep = Chr(9)
Case Else: strSep = Left(Trim(strSep), 1)
End Select
DateiName:
strDat = InputBox("Dateiname?", "DateiName", ThisWorkbook.Path & "\")
If strDat = "" Then Exit Sub
If InStr(strDat, ":\") = 0 Then
strDat = ThisWorkbook.Path & "\" & strDat
End If
If Dir(strDat) <> "" Then
strMldg = MsgBox("Datei bereits vorhanden. Überschreiben?", vbYesNo)
If strMldg = vbNo Then GoTo DateiName
End If
On Error GoTo DateiFehler
Open strDat For Output As #1
For iR = 1 To iRow
strTxt = ""
For iC = 1 To iCol
strTmp = Cells(iR, iC)
strTxt = strTxt & strTmp & strSep
Next iC
strTxt = Left(strTxt, Len(strTxt) - 1)
Print #1, strTxt
Next iR
Close #1
MsgBox ("Die Datei " & strDat & " wurde angelegt.")
Exit Sub
DateiFehler:
MsgBox ("Fehler in Dateinamen!")
Resume DateiName
End Sub