This code will do it:
Sub RangeToText()
Dim arr
Dim varDialogResult
Dim strFile As String
Dim strFileName As String
strFileName = Replace(ActiveWorkbook.Name, ".xls", ".txt", 1, -1,
vbTextCompare)
varDialogResult = _
Application.GetSaveAsFilename(InitialFileName:=strFileName, _
FileFilter:="Text Files (*.txt), *.txt")
'to take care of a cancelled dialog
'----------------------------------
If varDialogResult = False Then
Exit Sub
Else
strFile = varDialogResult
End If
If bFileExists(strFile) Then
If MsgBox(strFile & _
vbCrLf & vbCrLf & _
"Already exists, overwrite this file?", _
vbYesNo + vbDefaultButton2 + vbQuestion, _
"save range to text file") = vbNo Then
Exit Sub
End If
End If
arr = ActiveWindow.RangeSelection
SaveArrayToText strFile, arr
End Sub
Public Function bFileExists(ByVal sFile As String) As Boolean
Dim lAttr As Long
On Error Resume Next
lAttr = GetAttr(sFile)
bFileExists = (Err.Number = 0) And ((lAttr And vbDirectory) = 0)
On Error GoTo 0
End Function
Sub SaveArrayToText(ByVal txtFile As String, _
ByRef arr As Variant, _
Optional ByVal LBRow As Long = -1, _
Optional ByVal UBRow As Long = -1, _
Optional ByVal LBCol As Long = -1, _
Optional ByVal UBCol As Long = -1, _
Optional ByRef fieldArr As Variant)
Dim r As Long
Dim c As Long
Dim hFile As Long
If LBRow = -1 Then
LBRow = LBound(arr, 1)
End If
If UBRow = -1 Then
UBRow = UBound(arr, 1)
End If
If LBCol = -1 Then
LBCol = LBound(arr, 2)
End If
If UBCol = -1 Then
UBCol = UBound(arr, 2)
End If
hFile = FreeFile
Open txtFile For Output As hFile
If IsMissing(fieldArr) Then
For r = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next
Next
Else
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, fieldArr(c)
Else
Write #hFile, fieldArr(c);
End If
Next
For r = LBRow To UBRow
For c = LBCol To UBCol
If c = UBCol Then
Write #hFile, arr(r, c)
Else
Write #hFile, arr(r, c);
End If
Next
Next
End If
Close #hFile
End Sub
RBS
