vba Save as csv changes japanese characters to question marks

[detriez]

I am using this code in my .xlsm file to save the file as a CSV UTF-8 file

This works great for English characters but, it replaces non-Latin characters with a series of question marks

I can save this properly by using Save As > CSV UTF-8 Comma Delimited file

What can I be missing here?

Sub SaveFileAs(Control As IRibbonControl)

Dim fPth As Object
Set fPth = Application.FileDialog(msoFileDialogSaveAs)
Application.DisplayAlerts = False
    With fPth
      .InitialFileName = "SaveNewFile"
      .Title = "Save Prepped File"
      .FilterIndex = 2
      .InitialView = msoFileDialogViewList
            If .Show <> 0 Then
              ThisWorkbook.SaveAs FileName:=.SelectedItems(1), FileFormat:=xlOpenXMLWorkbook
            End If
    End With
Application.DisplayAlerts = True

End Sub

 

[Dan_W]

Hi. Looking at your code, it seems that regardless of what you/the user may select in the Save As dialog box, it will, in any event, be saved in [B]xlOpenXMLWorkbook [/B]and not as CSV:

ThisWorkbook.SaveAs FileName:=.SelectedItems(1), FileFormat:=xlOpenXMLWorkbook

That gives a FileFormat number of 51, whereas CSV UTF8 is 62. Try changing xlOpenXMLWorkbook in the line above to xlCSVUTF8

 

[Dan_W]

But also, before you run that code, I would just point out that you've referenced the workbook to be saved as CSV as being ThisWorkbook - meaning, the one which contains the very code you're trying run. If you save a macro-containing workbook as a CSV, you will strip it of all it's code. Is that what you want to happen?

 

[detriez]

Hi Dan.. I appreciate the response
This is a single use template file. We start fresh with a new macro workbook every time so, yes, ThisWorkbook is fine.. Unless you think it may be somehow interfering with the saving on f the csv UTF 8 formatting

I made the suggested change but still getting the question marks
I noticed the .FilterIndex changes from 16 to 2 after I run the code

Sub SaveFileAs(Control As IRibbonControl)

Dim fPth As Object
Set fPth = Application.FileDialog(msoFileDialogSaveAs)
Application.DisplayAlerts = False
    With fPth
      .InitialFileName = "SaveNewFile"
      .Title = "Save Prepped File"
      .FilterIndex = 2
      .InitialView = msoFileDialogViewList
            If .Show <> 0 Then
              ThisWorkbook.SaveAs FileName:=.SelectedItems(1), FileFormat:=xlCSVUTF8
            End If
    End With
Application.DisplayAlerts = True

End Sub

 

[Dan_W]

Hi
1. No, I don't think that the template issue is affecting the Japanese language encoding.
2. The .FilterIndex property changes to 2 because your code expressly directs it to:

.FilterIndex = 2

I would point out that the Filter Index for CSV UTF8 is 5.
3. In terms of the encoding, it's been a while since I lived in Japan and haven't had an occasion recently to delve back into the various encoding systems, but is UTF8 the correct one? All I can remember is that whenever I was presented with Mojibake, to try and convert it into Shift-JIS...

 

[detriez]

Some searching led me to this ..
It works but, I'm not sure how to incorporate the Save as dialog box instead of hard coding the path

Sub macro_01()
Const myDelim As String = ","
Dim WS As Worksheet

Set WS = ActiveSheet  '<<< convert data from active sheet
Dim r As Long, c As Long, i As Long, j As Long
r = WS.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
c = WS.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim myPath As String
myPath = ThisWorkbook.Path
Dim myFile As String
myFile = myPath & "\new File.csv"
Dim obj As Object
Set obj = CreateObject("ADODB.Stream")
obj.Type = 2
obj.Charset = "unicode"
'obj.Charset = "shift-jis"

''obj.Charset = "utf-8"
obj.Open
Dim v() As Variant
ReDim v(1 To c)
For i = 1 To r
For j = 1 To c
v(j) = WS.Cells(i, j)
Next
obj.WriteText Join(v, myDelim), 1
Next
obj.SaveToFile myFile, 2
obj.Close
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = Workbooks.Open(myFile)
Dim t As Long, x As Long
t = 1
Do
vv = Split(Cells(t, "A"), myDelim)
For x = 0 To UBound(vv)
Cells(t, x + 1) = vv(x)
Next
t = t + 1
Loop Until Cells(t, "A") = ""
Application.DisplayAlerts = False
wb.Save
wb.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "file is ready"
End Sub

 

[Dan_W]

Hi, that's great that you've worked out how to do it. I'll make a note of it in case I ever find myself having to save a CSV with Japanese in it (which is entirely likely!).

So I've updated your code to:

• Keep the original SaveFileAs subroutine - I see that this is connected to the ribbon. This now calls the new macro_01 sub.
• The macro_01 sub now calls a new function GetSaveAsFilename, which is the code that you and I worked on above. It returns the filename, which is preset with a filterindex of 5 to CSV UTF-8 (though that doesn't really mean much given that you're using ADODB (unicode) to save the file). You may wish to put it back to filterindex 16 ...
• I removed the MyPath variable, because it doesn't appear to be of use anymore.
• I added a small check to make sure that the filename that came back was not blank - if it is, then it will exit the sub. You may want to consider adding some additional error handling routines in here. For example, what do you want it to do if the file already exists?
• Also, I changed the last part of your code:

Application.DisplayAlerts = False
    wb.Save
    wb.Close
    Application.DisplayAlerts = True

I deleted the DisplayAlerts lines because it appears as though what you're trying to stop is the 'do you want save the file' confirmation dialog box - if that's the case, then this can be dealt with by adding a FALSE after the .Close line, so it now reads:

wb.Save
wb.Close False

The FALSE flag tells VBA that you don't want to save the file again... because your code has just done it - thereby avoiding the dialog box.
I wonder if there might be another issue with the code, but it's hard to say without recreating the workbook and settings involved. Anyway, I'll leave it to you to decide what you think about the changes I've proposed. The full code is below:

Sub SaveFileAs(Control As IRibbonControl)
    macro_01
End Sub
Sub macro_01()
   
    Const myDelim   As String = ","
   
    Dim WS          As Worksheet
   
    Set WS = ActiveSheet        '<<< convert data from active sheet
   
    Dim r           As Long, c As Long, i As Long, j As Long
   
    r = WS.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    c = WS.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
   
    Dim myFile      As String
    myFile = GetSaveAsFilename
    If myFile = vbNullString Then
        ' If the user presses cancel then this will exit the subroutine.
        Exit Sub
    End If
   
    Dim obj         As Object
    Set obj = CreateObject("ADODB.Stream")
   
    obj.Type = 2
    obj.Charset = "unicode"
   
    'obj.Charset = "shift-jis"
    ''obj.Charset = "utf-8"
    obj.Open
    Dim v()         As Variant
    ReDim v(1 To c)
    For i = 1 To r
        For j = 1 To c
            v(j) = WS.Cells(i, j)
        Next
        obj.WriteText Join(v, myDelim), 1
    Next
    obj.SaveToFile myFile, 2
    obj.Close
    Application.ScreenUpdating = False
   
    Dim wb          As Workbook
    Set wb = Workbooks.Open(myFile)
   
    Dim t           As Long, x As Long
    t = 1
    Do
        vv = Split(Cells(t, "A"), myDelim)
        For x = 0 To UBound(vv)
            Cells(t, x + 1) = vv(x)
        Next
        t = t + 1
    Loop Until Cells(t, "A") = ""

    wb.Save
    wb.Close False
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "file Is ready"
End Sub
Function GetSaveAsFilename() As String
    Dim fPth As Object
    Set fPth = Application.FileDialog(msoFileDialogSaveAs)
   
    With fPth
        .InitialFileName = "SaveNewFile"
        .Title = "Save Prepped File"
        .FilterIndex = 5
        .InitialView = msoFileDialogViewList
        If .Show <> 0 Then
                GetSaveAsFilename = .SelectedItems(1)
        End If
    End With
End Function

 

[detriez]

This is great.. Appreciate the help.
I hope you and others can benefit from this