excel vba exporting csv file quote qualifiers

Question

I am new to vba and need some help as I can't work this out

When trying to save some specific content from one of the worksheets in an excel workbook into a CSV file,I can't get the right output format. This is critical as some columns need text qualifiers and others do not and I have to get it right as the file will go into a enterprise solution.

I have 5 columns A-E that holds data I need to export as a csv, columns A,C & E need text qualifiers, but B & D do not.

The csv file has 2 header rows, which do not have any " qualifiers

I am trying to get this to work but have 2 issues 1) Columns A,C & E need to be in quotes, with B & D not in quotes 2) The header in row 1 has extra ,,,, on the end which I want to remove

The code I am using is below, and I've attached an image of a sample file to bring it to life.

The file does the following 1) Selects a dynamic range of rows within columns A-E 2) Saves as a specific name with data & time included it it.

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

The output it gives me is:

Export file name,,,,

Column1,Column2,Column3,Column4,Column5

name 1,Group1,Description 1,1,0

Name 2,Group2,Description 2,1,0

name 3,Group3,Description 3,1,0

name 4,Group4,Description 4,1,0

name 5,Group5,Description 5,1,0

name 6,Group6,Description 6,1,0

name 7,Group7,Description 7,1,0

I need it to be:

Export file name

Column1,Column2,Column3,Column4,Column5

"name 1",Group1,"Description 1",1,"0"

"Name 2",Group2,"Description 2",1,"0"

"name 3",Group3,"Description 3",1,"0"

"name 4",Group4,"Description 4",1,"0"

"name 5",Group5,"Description 5",1,"0"

"name 6",Group6,"Description 6",1,"0"

"name 7",Group7,"Description 7",1,"0"

I keep looping around different solutions, so need some expert guidance please.

All suggestions welcome as getting desperate Thanks

Excel file image

Dy.Lee Dy.Lee · Accepted Answer · 2017-06-12T16:24:13

I think do like this

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

excel vba exporting csv file quote qualifiers

1 Answers