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

我已经让你成为一个自定义子，用这两个替换sub - 最后一个param确定它是否为append并且它也将处理新行：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

将所有数据添加到＆＃34;列表＆＃34;

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

附加到文本文件VBA

4 个答案: