Enquoting a cell value in double quotes: Excel VBA Macro

Question

I want to put double quotes inside all cells in a particular column. I have wrote the code to put double quotes but the problem is it is putting 3 double quotes around the value.

 For Each myCell In ActiveWorkbook.Sheets("Sheet1").Range("B:B")
        If myCell.Value <> "" Then
            myCell.Value = Chr(34) & myCell.Value & Chr(34)
        End If
 Next myCell

The basic requirement is to split the excel file according to column B and save them as CSV files.
In the split filed, the values of column B and D must be enclosed within double quotes.

Full Code :

Option Explicit

Sub ParseItems()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
Dim myCell As Range, transCell As Range

'Sheet with data in it
   Set ws = Sheets("Sheet1")

'Path to save files into, remember the final \
    SvPath = "D:\SplitExcel\"

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
'Inserting new row to act as title, copying the data from first row in title, row deleted after use
    ws.Range("A1").EntireRow.Insert
    ws.Rows(2).EntireRow.Copy
    ws.Range("A1").Select
    ws.Paste
    vTitles = "A1:Z1"

'Choose column to evaluate from, column A = 1, B = 2, etc.
   vCol = 2
   If vCol = 0 Then Exit Sub

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Speed up macro execution
   Application.ScreenUpdating = False

'Get a temporary list of unique values from key column
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    'ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
        'transCell = ws.Range("A2:A" & LR)
        ws.Range("A2:A" & LR).EntireRow.Copy
        Workbooks.Add
        Range("A1").PasteSpecial xlPasteAll
        Cells.Columns.AutoFit
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1



        For Each myCell In ActiveWorkbook.Sheets("Sheet1").Range("B:B")
            If myCell.Value <> "" Then
               myCell.Value = Chr(34) & myCell.Value & Chr(34)
            End If
        Next myCell



        ActiveWorkbook.SaveAs SvPath & "po" & MyArr(Itm) & ActiveWorkbook.Sheets("Sheet1").Range("D1") & "." & Date2Julian(Date), xlCSV, local:=False
        ActiveWorkbook.Close False

        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.Rows(1).EntireRow.Delete
    ws.AutoFilterMode = False
    Application.ScreenUpdating = True
End Sub

Function Date2Julian(ByVal vDate As Date) As String

    Date2Julian = Format(DateDiff("d", CDate("01/01/" _
                  + Format(Year(vDate), "0000")), vDate) _
                  + 1, "000")



End Function

Sample Input Data :

24833837    8013    70  1105
25057089    8013    75  1105
25438741    8013    60  1105
24833837    8014    70  1106
25057089    8014    75  1106
25438741    8014    60  1106

Expected Output is Two files created with following data

File 1 :

24833837,"8013",70,1105
25057089,"8013",75,1105
25438741,"8013",60,1105

File 2:

24833837,"8014",70,1106
25057089,"8014",75,1106
25438741,"8014",60,1106

Resultant Output :

File 1 :

24833837,"""8013""",70,1105
25057089,"""8013""",75,1105
25438741,"""8013""",60,1105

Same for File 2

Kindly help. :)

Answer 1

This little sub will do as you need. Just give it a filename fname, range to export as csv rg and a column number column_with_quotes - so something like this but with a range to suit:

save_as_csv_with_optional_quotes SvPath & "po" & MyArr(Itm) & ActiveWorkbook.Sheets("Sheet1").Range("D1") & "." & Date2Julian(Date), Range("A1:C5"), 2

Here is the sub:

Sub save_as_csv_with_optional_quotes(fname As String, rg As Range, column_with_quotes As Long)
    Dim ff, r, c As Long
    Dim loutput, cl As String

    ff = FreeFile
    Open fname For Output As ff

        For r = 1 To rg.Rows.Count
            loutput = ""
            For c = 1 To rg.Columns.Count
                If loutput <> "" Then loutput = loutput & ","
                cl = rg.Cells(r, c).Value
                If c = column_with_quotes Then cl = Chr$(34) & cl & Chr$(34)
                loutput = loutput & cl
            Next c
            Print #ff, loutput
        Next r
    Close ff
End Sub

Answer 2

Afaik, there is no simple way to trick Excel into using quotes around numbers when using the normal "save as csv"-procedure. You can, however, use VBA to save in whatever csv format you like.

Take code example from https://support.microsoft.com/en-us/help/291296/procedure-to-export-a-text-file-with-both-comma-and-quote-delimiters-in-excel

Just add an if-statement to determine whether to use quotes or not

' Write current cell's text to file with quotation marks.
If WorksheetFunction.IsText(Selection.Cells(RowCount, ColumnCount)) Then
    Print #FileNum, """" & Selection.Cells(RowCount, _
        ColumnCount).Text & """";
Else
    Print #FileNum, Selection.Cells(RowCount, _
        ColumnCount).Text;
End If

The WorksheetFunction.IsText will recognize your numbers as text if they are entered with a preceding ' (single high quote)

You would need to adjust the example to export the range you want with the pre-given filename from your code.

Answer 3

the problem is this line.

myCell.Value = Chr(34) & myCell.Value & Chr(34)

The quotes you are adding are then being quoted again when you export as CSV, hence three quotes each side of the value. A better option I think would be to change the number format of the myCell to be Text, rather than number. I haven't tried this but I think changing it to this should help.

myCell.Value = Chr(39) & myCell.Value

Chr(39) is an apostrophe and when you enter it as the first character of a cell value it forces the format to be Text.