Enquoting a cell value in double quotes: Excel VBA Macro - vba

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

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 2

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 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.