Reputation: 137
I need to take values from a selected range to a comma delimited text file and append them. The code below gives me an error at Set TS. Why??
Sub Wri()
Dim myrng As Range
Dim Cell As Range
On Error Resume Next
Set myrng = Application.InputBox("Select range", Type:=8)
On Error GoTo 0
If myrng Is Nothing Then
MsgBox "No cells selected"
Exit Sub
End If
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fs, f, TS, s
Dim cellv As String
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateTextFile "C:\Users\HP\Documents\fil.txt"
Set f = fs.GetFile("C:\Users\HP\Documents\fil.txt")
Set TS = f.OpenTextFile(myrng.Value, 8, True, 0)
For Each Cell In myrng
cellv = Cell.Value
TS.Write (cellv & Chr(44))
Next Cell
End Sub
Upvotes: 6
Views: 76267
Reputation: 493
ah right try changing the call writeList to writeHList then and use this sub:
Sub writeHList(ByVal thisRange As Range, ByVal filePath As String, Optional ByVal fileAppend As Boolean = False)
Dim cLoop As Long, rLoop As Long
Dim ff As Long, strRow As String
Dim tCell As Range
Dim strLine
ff = FreeFile
If fileAppend Then
Open filePath For Append As #ff
Else
Open filePath For Output As #ff
End If
For Each tCell In thisRange
If strLine = "" Then
strLine = tCell.Value
Else
strLine = strLine & "," & tCell.Value
End If
Next tCell
Print #1, tCell.Value
Close #ff
End Sub
Upvotes: 1
Reputation: 493
to add all data to a "list"
Sub writeList(ByVal thisRange As Range, ByVal filePath As String, Optional ByVal fileAppend As Boolean = False)
Dim cLoop As Long, rLoop As Long
Dim ff As Long, strRow As String
Dim tCell As Range
ff = FreeFile
If fileAppend Then
Open filePath For Append As #ff
Else
Open filePath For Output As #ff
End If
For Each tCell In thisRange
Print #1, tCell.Value
Next tCell
Close #ff
End Sub
Sub Wri()
Dim myrng As Range
Dim Cell As Range
On Error Resume Next
Set myrng = Application.InputBox("Select range", Type:=8)
On Error GoTo 0
If myrng Is Nothing Then
MsgBox "No cells selected"
Exit Sub
Else
writeList myrng, "C:\Users\HP\Documents\fil.txt", True
End If
End Sub
Upvotes: 1
Reputation: 493
Ive made you a custom sub, replace the sub with these two - the last param determins if it is an append or not and it will handle the new lines too :D
Sub writeCSV(ByVal thisRange As Range, ByVal filePath As String, Optional ByVal fileAppend As Boolean = False)
Dim cLoop As Long, rLoop As Long
Dim ff As Long, strRow As String
ff = FreeFile
If fileAppend Then
Open filePath For Append As #ff
Else
Open filePath For Output As #ff
End If
For rLoop = 1 To thisRange.Rows.Count
strRow = ""
For cLoop = 1 To thisRange.Columns.Count
If cLoop > 1 Then strRow = strRow & ","
strRow = strRow & thisRange.Cells(rLoop, cLoop).Value
Next 'cLoop
Print #ff, strRow
Next 'rLoop
Close #ff
End Sub
Sub Wri()
Dim myrng As Range
Dim Cell As Range
On Error Resume Next
Set myrng = Application.InputBox("Select range", Type:=8)
On Error GoTo 0
If myrng Is Nothing Then
MsgBox "No cells selected"
Exit Sub
Else
writeCSV myrng, "C:\Users\HP\Documents\fil.txt", True
End If
End Sub
Upvotes: 15
Reputation: 493
try
Sub Wri()
Dim myrng As Range
Dim Cell As Range
On Error Resume Next
Set myrng = Application.InputBox("Select range", Type:=8)
On Error GoTo 0
If myrng Is Nothing Then
MsgBox "No cells selected"
Exit Sub
End If
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fs, f, TS, s
Dim cellv As String
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateTextFile "C:\Users\HP\Documents\fil.txt"
Set TS = fs.OpenTextFile("C:\Users\HP\Documents\fil.txt", 8, True, 0)
For Each Cell In myrng
cellv = Cell.Value
TS.Write (cellv & Chr(44))
Next Cell
End Sub
Upvotes: 4