XL 2010 Symbole monétaire changé en point d'interrogation dans fichier CSV

    For Each c In ActiveSheet.Range("D2:D" & ActiveSheet.UsedRange.Rows.Count)
        c.Value = "￥" & Left(c.Value, Len(c.Value) - 3) & "," & Right(c.Value, 3)
    Next c

toto = AscW(Range("A1").Value)
titi = Asc(Range("A1").Value)
MsgBox toto & " ---> " & ChrW(toto)
MsgBox titi & " ---> " & Chr(titi)

tata = Split(StrConv(Range("A1").Value, vbUnicode), Chr(0))
MsgBox tata(0)

ActiveWorkbook.SaveAs ListDir & "タグリスト" & toujitsu & "." & i & ".csv", FileFormat:=xlCSV, AddToMru:=False

[CODE=vb]ActiveWorkbook.SaveAs ListDir & "タグリスト" & toujitsu & "." & i & ".csv", FileFormat:=xlCSV, Local:=True, AddToMru:=False

Sub CsvUtf8()

Const Delim As String = ","   '<--  virgule ou point virgule

Dim Ash As Worksheet: Set Ash = ActiveSheet

Ash.Columns("D").NumberFormatLocal = "￥#,##0 " ' <-- Y mettre ce qu'il faut pour afficher le Yen Monétaire

Dim Rows As Long
    Rows = Ash.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Dim Cols As Long
    Cols = Ash.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
Dim FileName As String
FileName = ListDir & "\Sample.csv" '<--  file name

Dim I As Long, J As Long

Dim Adobj As Object
Set Adobj = CreateObject("ADODB.Stream")
   Adobj.Type = 2 'adTypeText'
   Adobj.Charset = "utf-8"
   Adobj.Open
    Dim Vcells() As Variant
    ReDim Vcells(1 To Cols)
    For I = 1 To Rows
       For J = 1 To Cols
           Vcells(J) = Ash.Cells(I, J).Text
       Next
       Adobj.WriteText Join(Vcells, Delim), 1 'adWriteLine
    Next
   Adobj.SaveToFile FileName, 2 'adSaveCreateOverWrite
Set Adobj = Nothing

MsgBox "Exporté dans " & FileName
End Sub

Sub CsvUtf8()

Const Delim As String = ","   '<--  virgule ou point virgule
Const Mon As String = "¥"     '<-- Symbole du Yen dans le code local
Dim Ash As Worksheet: Set Ash = ActiveSheet

Ash.Columns("D").NumberFormatLocal = Mon & "#,##0" ' <-- D'après le premier fichier fourni

Dim Rows As Long
    Rows = Ash.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Dim Cols As Long
    Cols = Ash.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
   
Dim FileName As String
FileName = ListDir & "\Sample.csv" '<--  file name

Dim I As Long, J As Long

Dim Adobj As Object
Set Adobj = CreateObject("ADODB.Stream")
   Adobj.Type = 2 'adTypeText'
   Adobj.Charset = "utf-8"
   Adobj.Open
    Dim Vcells() As Variant
    ReDim Vcells(1 To Cols)
    For I = 1 To Rows
       For J = 1 To Cols
        Vcells(J) = Ash.Cells(I, J).Text
        If InStr(Vcells(J), Mon) _
        Then Vcells(J) = """" & Vcells(J) & """"
       Next
       Adobj.WriteText Join(Vcells, Delim), 1 'adWriteLine
    Next
   Adobj.SaveToFile FileName, 2 'adSaveCreateOverWrite
Set Adobj = Nothing

MsgBox "Exporté dans " & vbLf & FileName
End Sub