0

好的，所以我想在 Excel 2003 中有一个宏，它将当前工作表保存为 .txt 文件。我已经使用以下代码获得了该部分：

Dim filename As String
Dim path As String
filename = InputBox("Please enter file name", "Save as CSV", "CSV_" & Format(Now, "DD_MM_yyyy"))
path = "C:\Temp" & filename & ".txt"

ActiveWorkbook.SaveAs filename:=path, FileFormat:=xlTextMSDOS, CreateBackup:=False

但现在是实际问题：在我的工作表中有一些包含逗号的单元格。如果我使用上面显示的宏，文件将保存为 CSV，但包含逗号的单元格周围有引号。我不要那个。如果我通过文件 -> 另存为 -> CSV/TXT 手动保存文件，则生成的文件不包含这些引号。

有谁知道如何解决这个问题？

非常感谢！

编辑：我忘了说，手动保存时，我选择了文本制表符分隔，而不是逗号分隔。

4

3 回答 3

1

好吧，让我们看看我在阁楼里有什么......

我有一个符合要求的 VBA Array To File功能：对于您正在做的工作可能有点矫枉过正，因为您不需要标题行、转置和检查带有错误陷阱的预先存在文件的选项读取文件的日期戳并防止对函数的重复调用不断覆盖文件。但这是我手头的代码，简化它比按原样使用更麻烦。

你想要的是这个函数默认使用制表符作为字段分隔符。当然，您可以将其设置为逗号... csv 文件的普遍接受定义是用逗号分隔的字段和封装在双引号中的文本字段（可能包含逗号字符）。但是我不能声称可以证明这种迂腐的道德制高点，因为下面的代码没有强加封装引号。

编码说明：

  1. 您需要对 Windows 脚本运行时库的引用：scrrun.dll - 这可以在系统文件夹（通常是 C:\WINDOWS\system32）中找到 - 因为我们使用的是文件系统对象；
  2. ArrayToFile 将数据写入临时文件夹中的命名文件。如果您指定“CopyFilePath”，它将被复制到其他地方：永远不要写入网络文件夹，写入本地驱动器并使用本机文件系统功能移动或复制完成的文件总是更快；
  3. 数据以块的形式写入文件，而不是逐行写入；
  4. 有进一步优化的空间：使用 Split 和 Join 函数将消除循环中的字符串连接；
  5. 您可能希望使用 VbCrLF 而不是 VbCr 作为行分隔符：回车通常可以工作，但某些系统和应用程序需要回车和换行符组合才能正确读取或显示换行符。
使用 ArrayToFile 函数：

这很简单：只需输入工作表使用范围的 .Value2 属性：



   ArrayToFile Worksheets("Sheet1").UsedRange.Value2, "MyData.csv"

'Value2' 的原因是 'Value' 属性捕获格式，您可能需要日期字段的基础序列值。

VBA ArrayToFile 函数的源代码：

分享和享受......并注意有用的换行符，插入任何可以通过浏览器（或 StackOverflow 的有用格式化功能）破坏代码的地方：


Public Sub ArrayToFile(ByVal arrData As Variant, _
                       ByVal strName As String, _
                       Optional MinFileAge As Double = 0, _
                       Optional Transpose As Boolean = False, _
                       Optional RowDelimiter As String = vbCr, _
                       Optional FieldDelimiter = vbTab, _
                       Optional CopyFilePath As String, _
                       Optional NoEmptyRows As Boolean = True, _
                       Optional arrHeader1 As Variant, _
                       Optional arrHeader2 As Variant)



' Output an array to a file. The field delimiter is tab (char 9); rows use CarriageReturn(char 13).
' The file will be named as specified by strName, and saved in the user's Windows Temp folder.



' Specify CopyFilePath (the full name and path) to copy this temporary file to another folder.
' Saving files locally and copying them is much faster than writing data across the network.



' If a Min File Age 'n' is specified, and n is greater than zero, an existing file will not be
' replaced, and no data will be written unless the file is more than MinFileAge seconds old.



' Transpose = TRUE is useful for arrays generated by Recordset.GetRows and ListControl.Column
' Note that ADODB.Recordset has a native 'save' method (rows delimited by VbCr, fields by Tab)



' **** This code is in the Public Domain **** Nigel Heffernan http://Excellerando.blogspot.com



On Error Resume Next



Dim objFSO As Scripting.FileSystemObject
Set objFSO = New Scripting.FileSystemObject



If objFSO Is Nothing Then
    Shell "Regsvr32.exe /s scrrun.dll", vbHide
    Application.Wait Now + (0.25 / 3600 / 24)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
End If



If objFSO Is Nothing Then
    Exit Sub
End If



Dim strFile     As String
Dim strTemp     As String



Dim i As Long, j As Long



Dim strData     As String
Dim strLine     As String



Dim strEmpty    As String
Dim dblCount    As Double



Const BUFFERLEN As Long = 255



strName = Replace(strName, "[", "")
strName = Replace(strName, "]", "")



Set objFSO = New Scripting.FileSystemObject



If objFSO Is Nothing Then
    Shell "Regsvr32.exe /s scrrun.dll", vbHide
    Application.Wait Now + (0.25 / 3600 / 24)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
End If



If objFSO Is Nothing Then
    Exit Sub
End If



strTemp = objFSO.GetSpecialFolder(Scripting.TemporaryFolder).ShortPath



strFile = objFSO.BuildPath(strTemp, strName)



If objFSO.FileExists(strFile) Then



If MinFileAge > 0 Then
    If objFSO.GetFile(strFile).DateCreated + (MinFileAge / 3600 / 24) > Now Then
        Set objFSO = Nothing
        Exit Sub
    End If
End If

Err.Clear
objFSO.DeleteFile strFile, True

If Err.Number = 70 Then
    VBA.FileSystem.Kill strFile
End If




End If



If objFSO.FileExists(strFile) Then
    Exit Sub
End If



Application.StatusBar = "Cacheing data in a temp file... "



strData = vbNullString
With objFSO.OpenTextFile(strFile, ForWriting, True)



' **** **** **** HEADER1 **** **** ****
If Not IsMissing(arrHeader1) Then
If Not IsEmpty(arrHeader1) Then
If InStr(1, TypeName(arrHeader1), "(") > 1 Then  ' It's an array...

    Select Case ArrayDimensions(arrHeader1)
    Case 1  ' Vector array

       .Write Join(arrHeader1, RowDelimiter)

    Case 2 ' 2-D array... 3-D arrays are not handled

        If Transpose = True Then

            For i = LBound(arrHeader1, 2) To UBound(arrHeader1, 2)

                For j = LBound(arrHeader1, 1) To UBound(arrHeader1, 1)

                    strData = strData & FieldDelimiter & CStr(arrHeader1(j, i))

                Next j

                strData = strData & RowDelimiter

            Next i

       Else   ' not transposing:

            For i = LBound(arrHeader1, 1) To UBound(arrHeader1, 1)

                For j = LBound(arrHeader1, 2) To UBound(arrHeader1, 2)

                    strData = strData & CStr(arrHeader1(i, j))

                    If j < UBound(arrHeader1, 2) Then
                        strData = strData & FieldDelimiter
                    End If

                Next j

                strData = strData & RowDelimiter

            Next i

        End If ' Transpose

    End Select


 '   .Write strData
 '   strData = vbNullString
    Erase arrHeader1

Else ' treat it as a string
    If LenB(arrHeader1) > 0 Then
        .Write arrHeader1
    End If
End If
End If 'Not IsMissing(arrHeader1)
End If 'Not IsEmpty(arrHeader1)



' **** **** **** HEADER2 **** **** ****
If Not IsMissing(arrHeader2) Then
If Not IsEmpty(arrHeader2) Then
If InStr(1, TypeName(arrHeader2), "(") > 1 Then  ' It's an array...

    Select Case ArrayDimensions(arrHeader2)
    Case 1  ' Vector array

       .Write Join(arrHeader2, RowDelimiter)

    Case 2 ' 2-D array... 3-D arrays are not handled

        If Transpose = True Then

            For i = LBound(arrHeader2, 2) To UBound(arrHeader2, 2)

                For j = LBound(arrHeader2, 1) To UBound(arrHeader2, 1)

                    strData = strData & FieldDelimiter & CStr(arrHeader2(j, i))

                Next j

                strData = strData & RowDelimiter

            Next i

       Else   ' not transposing:

            For i = LBound(arrHeader2, 1) To UBound(arrHeader2, 1)

                For j = LBound(arrHeader2, 2) To UBound(arrHeader2, 2)

                    strData = strData & CStr(arrHeader2(i, j))

                    If j < UBound(arrHeader2, 2) Then
                        strData = strData & FieldDelimiter
                    End If

                Next j

                strData = strData & RowDelimiter

            Next i

        End If ' Transpose

    End Select        

 '   .Write strData
 '   strData = vbNullString
    Erase arrHeader2

Else ' treat it as a string
    If LenB(arrHeader2) > 0 Then
        .Write arrHeader2
    End If
End If
End If 'Not IsMissing(arrHeader2)
End If 'Not IsEmpty(arrHeader2)


' **** **** **** BODY **** **** ****

If InStr(1, TypeName(arrData), "(") > 1 Then
    ' It's an array...

    Select Case ArrayDimensions(arrData)
    Case 1

        If NoEmptyRows Then
            .Write Replace$(Join(arrData, RowDelimiter), RowDelimiter & RowDelimiter, "")
        Else
            .Write Join(arrData, RowDelimiter)
        End If

    Case 2

        If Transpose = True Then

            strEmpty = String(UBound(arrData, 1) - 1, FieldDelimiter) & RowDelimiter

            For i = LBound(arrData, 2) To UBound(arrData, 2)

                For j = LBound(arrData, 1) To UBound(arrData, 1)

                    strData = strData & FieldDelimiter & CStr(arrData(j, i))

                Next j

                strData = strData & RowDelimiter

                If (Len(strData) \ 1024) > BUFFERLEN Then

                    If NoEmptyRows Then
                        strData = Replace$(strData, strEmpty, "")
                        'strData = Replace$(strData, RowDelimiter & RowDelimiter, "")
                    End If

                    Application.StatusBar = "Cacheing data in a temp file... (" & Format(dblCount + (Len(strData) \ 1024), "0,000") & "kB)"

                    dblCount = dblCount + (Len(strData) \ 1024)
                    .Write strData
                    strData = vbNullString
                End If


            Next i

        Else   ' not transposing:

            strEmpty = String(UBound(arrData, 2) - 1, FieldDelimiter) & RowDelimiter

            For i = LBound(arrData, 1) To UBound(arrData, 1)

                For j = LBound(arrData, 2) To UBound(arrData, 2)

                    strData = strData & CStr(arrData(i, j))

                    If j < UBound(arrData, 2) Then
                        strData = strData & FieldDelimiter
                    End If

                Next j

                strData = strData & RowDelimiter

                If (Len(strData) \ 1024) > BUFFERLEN Then

                    If NoEmptyRows Then
                        strData = Replace$(strData, strEmpty, "")
                        'strData = Replace$(strData, RowDelimiter & RowDelimiter, "")
                    End If

                    Application.StatusBar = "Cacheing data in a temp file... (" & Format(dblCount + (Len(strData) \ 1024), "0,000") & "kB)"

                    dblCount = dblCount + (Len(strData) \ 1024)
                    .Write strData
                    strData = vbNullString
                End If

            Next i

        End If ' Transpose

    End Select

    If NoEmptyRows Then
        strData = Replace$(strData, strEmpty, "")
        'strData = Replace$(strData, RowDelimiter & RowDelimiter, "")
    End If

    If Right$(strData, Len(RowDelimiter)) = RowDelimiter Then
        Mid$(strData, Len(strData) - Len(RowDelimiter), Len(RowDelimiter)) = ""
    End If


    .Write strData
    strData = vbNullString
    Erase arrData

Else ' treat it as a string

     .Write arrData

End If




.Close
End With ' textstream object from objFSO.OpenTextFile



If CopyFilePath <> "" Then



Application.StatusBar = "Copying " & strName & " to " & CopyFilePath & "..."
objFSO.CopyFile strFile, CopyFilePath, True




End If



Application.StatusBar = False
Set objFSO = Nothing
strData = vbNullString



End Sub

为了完整起见，这里是从文件读取到数组的补充函数，以及清理临时文件的粗略子程序：




Public Sub FileToArray(arrData As Variant, strName As String, Optional MaxFileAge As Double = 0, Optional RowDelimiter As String = vbCr, Optional FieldDelimiter = vbTab, Optional CoerceLowerBound As Long = 0) ' Load a file created by FileToArray into a 2-dimensional array
' The file name is specified by strName, and it is exected to exist in the user's temporary folder.
' This is a deliberate restriction: it's always faster to copy remote files to a local drive than to edit them across the network
' If a Max File Age 'n' is specified, and n is greater than zero, files more than n seconds old will NOT be read.



' **** This code is in the Public Domain **** Nigel Heffernan http://Excellerando.blogspot.com



On Error Resume Next



Dim objFSO As Scripting.FileSystemObject
Set objFSO = New Scripting.FileSystemObject



If objFSO Is Nothing Then
    Shell "Regsvr32.exe /s scrrun.dll", vbHide
    Application.Wait Now + (0.25 / 3600 / 24)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
End If



If objFSO Is Nothing Then
    Exit Sub
End If



Dim strFile As String
Dim strTemp As String



Dim i   As Long
Dim j   As Long



Dim i_n As Long
Dim j_n As Long



Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long



Dim arrTemp1 As Variant
Dim arrTemp2 As Variant



Dim dblCount As Double



Set objFSO = New Scripting.FileSystemObject



If objFSO Is Nothing Then
    Shell "Regsvr32.exe /s scrrun.dll", vbHide
    Application.Wait Now + (0.25 / 3600 / 24)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
End If



If objFSO Is Nothing Then
    Exit Sub
End If



strTemp = objFSO.GetSpecialFolder(Scripting.TemporaryFolder).ShortPath



strFile = objFSO.BuildPath(strTemp, strName)



If Not objFSO.FileExists(strFile) Then
    Exit Sub
End If



If MaxFileAge > 0 Then
    ' If the file's a bit elderly, bail out - the calling function will refresh the data from source
    If objFSO.GetFile(strFile).DateCreated + (MaxFileAge / 3600 / 24) < Now Then
        Set objFSO = Nothing
        Exit Sub
    End If



End If



Application.StatusBar = "Reading the file... (" & strName & ")"



arrData = Split2d(objFSO.OpenTextFile(strFile, ForReading).ReadAll, RowDelimiter, FieldDelimiter, CoerceLowerBound)



Application.StatusBar = "Reading the file... Done"



Set objFSO = Nothing



End Sub



Public Sub RemoveTempFiles(ParamArray FileNames())



On Error Resume Next



Dim objFSO As Scripting.FileSystemObject
Set objFSO = New Scripting.FileSystemObject



If objFSO Is Nothing Then
    Shell "Regsvr32.exe /s scrrun.dll", vbHide
    Application.Wait Now + (0.25 / 3600 / 24)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
End If



If objFSO Is Nothing Then
    Exit Sub
End If



Dim varName As Variant
Dim strName As String
Dim strFile As String
Dim strTemp As String



strTemp = objFSO.GetSpecialFolder(Scripting.TemporaryFolder).ShortPath



For Each varName In FileNames



strName = vbNullString
strFile = vbNullString

strName = CStr(varName)
strFile = objFSO.BuildPath(strTemp, strName)

If objFSO.FileExists(strFile) Then
    objFSO.DeleteFile strFile, True
End If




Next varName



Set objFSO = Nothing



End Sub

我建议您将其保留在 Option Private Module 下的模块中 - 这不是我希望其他用户直接从工作表调用的那种功能。

于 2012-08-21T11:10:48.830 回答
0

这是不可能的（有点）。

包含分隔符的字段必须用引号引起来。否则，该字段将被分隔符“一分为二”。

唯一的解决方案是使用不同的分隔符，例如制表符（有效地将其更改为 TSV 文件），这当然只有在数据中也没有出现新的分隔符时才有效。

于 2012-08-21T08:58:56.217 回答
0

如果这些SaveAs格式都不适合您，请编写您的解析器，例如

Sub SaveFile()
    Dim rng As Range
    Dim rw As Range
    Dim ln As Variant

    ' Set rng to yout data range, eg
    Set rng = ActiveSheet.UsedRange

    Open "C:\Temp\TESTFILE.txt" For Output As #1    ' Open file for output.
    For Each rw In rng.Rows
        ln = Join(Application.Transpose(Application.Transpose(rw)), vbTab)
        Print #1, ln; vbNewLine;
    Next
    Close #1
End Sub
于 2012-08-21T09:38:16.823 回答