web-dev-qa-db-ja.com

テキストファイルVBAに追加

選択した範囲からカンマ区切りのテキストファイルに値を取得して追加する必要があります。以下のコードは、SetTSでエラーが発生します。なぜ？？

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
vbaexcel-vbadelimited-textexcel
5
Neha

私はあなたにカスタムサブを作りました、サブをこれらの2つに置き換えてください-最後のパラメータはそれが追加であるかどうかを決定し、それは新しい行も処理します：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
12
Denzil Newman

試してみてください

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
3
Denzil Newman

ああ、そうです、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
1
Denzil Newman

すべてのデータを「リスト」に追加するには

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
1
Denzil Newman