CODEWITHSUNDEEP
vbaexcelcsv
Neha
Neha

Reputation: 137

Append to Text File VBA

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

Answers (4)

Denzil Newman
Denzil Newman

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

Denzil Newman
Denzil Newman

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

Denzil Newman
Denzil Newman

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

Denzil Newman
Denzil Newman

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

Related Questions