excel vba导出csv文件报价限定符

Question

我是 vba 新手，需要一些帮助，因为我无法解决这个问题

当尝试将某些特定内容从 Excel 工作簿中的一个工作表保存到 CSV 文件中时，我无法获得正确的输出格式。这很关键，因为有些列需要文本限定符，而另一些则不需要，我必须正确处理，因为文件将进入企业解决方案。

我有 5 列 A-E 包含我需要导出为 csv 的数据，A、C 和 E 列需要文本限定符，但 B 和 D 不需要。

csv 文件有 2 个标题行，它们没有任何 " 限定符

我正在尝试让它工作，但有 2 个问题 1) A、C 和 E 列需要加引号，B 和 D 不加引号 2) 第 1 行的标题在我要删除的末尾有多余的 ,,,,

我正在使用的代码如下，我附上了一个示例文件的图像以使其栩栩如生。

该文件执行以下操作 1) 在 A-E 列中选择动态范围的行 2) 保存为包含数据和时间的特定名称。

Sub SaveDynamicRangeAsCSVFile_IncTextDelimiters()

'Turn off screen updating for performance and prevent dizziness
     Application.ScreenUpdating = False

'Set-up
    Dim MyPath As String
    Dim MyFileName As String
    Dim WB1 As Workbook, WB2 As Workbook
    Set WB1 = ActiveWorkbook
    MyFileName = "ProdTabData-" & Format(Date, "yyyymmdd-") & Format(Time, "hhmmss")
    FullPath = WB1.Path & "\" & MyFileName

'Dynamic range identified
    Application.ScreenUpdating = False
    Range("A5:E" & Cells(Rows.Count, 1).End(xlUp).Row).Copy
    Set WB2 = Application.Workbooks.Add(1)
    WB2.Sheets(1).Range("A1").PasteSpecial xlPasteValues
    Application.DisplayAlerts = False

'save file
    If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
    With WB2
        .SaveAs Filename:=FullPath, FileFormat:=xlCSV, CreateBackup:=False
        .Close False
    End With
    Application.DisplayAlerts = False

'Turn on screen updating
        Application.ScreenUpdating = True

End Sub

它给我的输出是：

导出文件名,,,,

第 1 列、第 2 列、第 3 列、第 4 列、第 5 列

名称 1,Group1,描述 1,1,0

名称 2,Group2,描述 2,1,0

名称 3,Group3,描述 3,1,0

名称 4,Group4,描述 4,1,0

名称 5,Group5,描述 5,1,0

名称 6,Group6,描述 6,1,0

名称 7,Group7,描述 7,1,0

我需要它：

导出文件名

第 1 列、第 2 列、第 3 列、第 4 列、第 5 列

"名称 1",Group1,"描述 1",1,"0"

"名称 2",Group2,"描述 2",1,"0"

"名称 3",Group3,"描述 3",1,"0"

"名称 4",Group4,"描述 4",1,"0"

"名称 5",Group5,"描述 5",1,"0"

"名称 6",Group6,"描述 6",1,"0"

"名称 7",Group7,"描述 7",1,"0"

我一直在寻找不同的解决方案，所以需要一些专家指导。

欢迎所有建议，因为越来越绝望 谢谢

Excel file image

Answer 1

我想这样做

Sub SaveDynamicRangeAsCSVFile_IncTextDelimiters()
    Dim rngDB As Range
'Turn off screen updating for performance and prevent dizziness
     Application.ScreenUpdating = False

'Set-up
    Dim MyPath As String
    Dim MyFileName As String
    Dim WB1 As Workbook, WB2 As Workbook
    Set WB1 = ActiveWorkbook
    MyFileName = "ProdTabData-" & Format(Date, "yyyymmdd-") & Format(Time, "hhmmss")
    FullPath = WB1.Path & "\" & MyFileName

'Dynamic range identified
    Application.ScreenUpdating = False
    Set rngDB = Range("A5:E" & Cells(Rows.Count, 1).End(xlUp).Row)
    Application.DisplayAlerts = False

'save file
    If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
    Application.DisplayAlerts = False
    TransToCSV MyFileName, rngDB
'Turn on screen updating
        Application.ScreenUpdating = True

End Sub
Sub TransToCSV(myfile As String, rng As Range)

    Dim vDB, vR() As String, vTxt()
    Dim i As Long, n As Long, j As Integer
    Dim objStream
    Dim strTxt As String

    Set objStream = CreateObject("ADODB.Stream")
    vDB = rng
    For i = 1 To UBound(vDB, 1)
        n = n + 1
        ReDim vR(1 To UBound(vDB, 2))
        For j = 1 To UBound(vDB, 2)
            Select Case j
            Case 1, 3, 5
                If i = 2 Then
                    vR(j) = vDB(i, j)
                Else
                    vR(j) = Chr(34) & vDB(i, j) & Chr(34)
                End If
            Case Else
                vR(j) = vDB(i, j)
            End Select
        Next j
        ReDim Preserve vTxt(1 To n)
        If i = 1 Then
            vTxt(n) = vDB(1, 1)
        Else
            vTxt(n) = Join(vR, ",")
        End If
    Next i
    strTxt = Join(vTxt, vbCrLf)
    With objStream
        '.Charset = "utf-8"
        .Open
        .WriteText strTxt
        .SaveToFile myfile, 2
        .Close
    End With
    Set objStream = Nothing

End Sub