Exporter une feuille sous forme de fichier CSV UTF-8 (en utilisant Excel-VBA)

Question

Je souhaite exporter un fichier que j'ai créé dans UTF-8 CSV en utilisant VBA. De la recherche forums, j'ai trouvé le code suivant qui convertit un fichier en UTF-8 (from this thread):

Sub SaveAsUTF8() 

    Dim fsT, tFileToOpen, tFileToSave As String 

    tFileToOpen = InputBox("Enter the name and location of the file to convert" & vbCrLf & "With full path and filename ie. C:\MyFolder\ConvertMe.Txt") 
    tFileToSave = InputBox("Enter the name and location of the file to save" & vbCrLf & "With full path and filename ie. C:\MyFolder\SavedAsUTF8.Txt") 

    tFileToOpenPath = tFileToOpen 
    tFileToSavePath = tFileToSave 

Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object 
fsT.Type = 2: 'Specify stream type – we want To save text/string data. 
fsT.Charset = "utf-8": 'Specify charset For the source text data. 

fsT.Open: 'Open the stream 
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream 

fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path 

End Sub 

Cependant, ce code ne convertit un fichier non-UTF-8 en UTF-8. Si je devais enregistrer mon fichier en non-UTF-8 et le convertir en UTF-8, il aurait déjà perdu tous les caractères spéciaux qu'il contenait, rendant ainsi le processus inutile!

Ce que je cherche à faire est d'enregistrer un fichier ouvert en UTF-8 (CSV). Y at-il un moyen de le faire avec VBA?

n.b. J'ai également posé cette question sur le 'ozgrid' forum. Ferme les deux threads ensemble si je trouve une solution.

Answer 1

Mise à jour de ce code. J'ai utilisé celui-ci pour changer tous les fichiers .csv dans un dossier spécifié (portant la mention « Bron ») et les enregistrer en tant que csv utf-8 dans un autre dossier (appelé « Doel »)

Sub SaveAsUTF8() 

Dim fsT As Variant, tFileToOpen As String, tFileToSave As String 
Dim Message As String 
Dim wb As Workbook 
Dim fileName As String 

Set wb = ActiveWorkbook 

With Application 
.ScreenUpdating = False 
.DisplayAlerts = False 
End With 

Message = "Source folder incorrect" 
SourceFolder = wb.Worksheets("Menu").Range("Bron") & "\" 
If Dir(SourceFolder, vbDirectory) = "" Or IsEmpty(SourceFolder) Then GoTo errorhandler 

Message = "Target folder incorrect" 
TargetFolder = wb.Worksheets("Menu").Range("Doel") & "\" 
If Dir(TargetFolder, vbDirectory) = "" Or IsEmpty(TargetFolder) Then GoTo errorhandler 

fileName = Dir(SourceFolder & "\*.csv", vbNormal) 

Message = "No files available." 
If Len(fileName) = 0 Then GoTo errorhandler 

Do Until fileName = "" 

    tFileToOpen = SourceFolder & fileName 
    tFileToSave = TargetFolder & fileName 

    tFileToOpenPath = tFileToOpen 
    tFileToSavePath = tFileToSave 

Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object 
fsT.Type = 2: 'Specify stream type – we want To save text/string data. 
fsT.Charset = "utf-8": 'Specify charset For the source text data. 

fsT.Open: 'Open the stream 
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream 

fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path 

fileName = Dir() 

Loop 

Message = "Okay to remove all old files?" 
If QuestionMessage(Message) = False Then 
    GoTo the_end 
Else 
    On Error Resume Next 
    Kill SourceFolder & "*.csv" 
    On Error GoTo errorhandler 
End If 

the_end: 
With Application 
.ScreenUpdating = True 
.DisplayAlerts = True 
End With 
Exit Sub 

errorhandler: 
With Application 
.ScreenUpdating = True 
.DisplayAlerts = True 
End With 
CriticalMessage (Message) 
Exit Sub 

End Sub 

'---------- 

Function CriticalMessage(Message As String) 

MsgBox Message 

End Function 

'---------- 

Function QuestionMessage(Message As String) 

If MsgBox(Message, vbQuestion + vbYesNo) = vbNo Then 
QuestionMessage = False 
Else 
QuestionMessage = True 
End If 

End Function 

Answer 2

Voici ma solution basée sur Excel VBA - export to UTF-8 , auquel utilisateur3357963 lié à plus tôt. Il comprend des macros pour exporter une gamme et une sélection.

Option Explicit 

Const strDelimiter = """" 
Const strDelimiterEscaped = strDelimiter & strDelimiter 
Const strSeparator = "," 
Const strRowEnd = vbCrLf 
Const strCharset = "utf-8" 

Function CsvFormatString(strRaw As String) As String 

    Dim boolNeedsDelimiting As Boolean 

    boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _ 
     Or InStr(1, strRaw, Chr(10)) > 0 _ 
     Or InStr(1, strRaw, strSeparator) > 0 

    CsvFormatString = strRaw 

    If boolNeedsDelimiting Then 
     CsvFormatString = strDelimiter & _ 
      Replace(strRaw, strDelimiter, strDelimiterEscaped) & _ 
      strDelimiter 
    End If 

End Function 

Function CsvFormatRow(rngRow As Range) As String 

    Dim arrCsvRow() As String 
    ReDim arrCsvRow(rngRow.Cells.Count - 1) 
    Dim rngCell As Range 
    Dim lngIndex As Long 

    lngIndex = 0 

    For Each rngCell In rngRow.Cells 
     arrCsvRow(lngIndex) = CsvFormatString(rngCell.Text) 
     lngIndex = lngIndex + 1 
    Next rngCell 


    CsvFormatRow = Join(arrCsvRow, ",") & strRowEnd 

End Function 

Sub CsvExportRange(_ 
     rngRange As Range, _ 
     Optional strFileName As Variant _ 
    ) 

    Dim rngRow As Range 
    Dim objStream As Object 

    If IsMissing(strFileName) Or IsEmpty(strFileName) Then 
     strFileName = Application.GetSaveAsFilename(_ 
      InitialFileName:=ActiveWorkbook.Path & "\" & rngRange.Worksheet.Name & ".csv", _ 
      FileFilter:="CSV (*.csv), *.csv", _ 
      Title:="Export CSV") 
    End If 

    Set objStream = CreateObject("ADODB.Stream") 
    objStream.Type = 2 
    objStream.Charset = strCharset 
    objStream.Open 

    For Each rngRow In rngRange.Rows 
     objStream.WriteText CsvFormatRow(rngRow) 
    Next rngRow 

    objStream.SaveToFile strFileName, 2 
    objStream.Close 

End Sub 

Sub CsvExportSelection() 
    CsvExportRange ActiveWindow.Selection 
End Sub 

Sub CsvExportSheet(varSheetIndex As Variant) 

    Dim wksSheet As Worksheet 
    Set wksSheet = Sheets(varSheetIndex) 

    CsvExportRange wksSheet.UsedRange 

End Sub