Добавить в текстовый файл VBA

Question

Мне нужно взять значения из выбранного диапазона в текстовый файл с разделителями-запятыми и добавить их. Код ниже дает мне ошибку в Set TS. Зачем??

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

Answer 1

Я сделал вам пользовательскую подпрограмму, замените подпрограмму этими двумя - последний параметр определяет, является ли он добавлением или нет, и он также будет обрабатывать новые строки: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

Answer 2

Пытаться

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

Answer 3

Добавить все данные в "список"

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

Answer 4

Ну правильно попробуйте изменить вызов writeList на writeHList тогда и используйте эту подпрограмму:

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