Exporter la feuille en tant que UTF-8 fichier CSV (à l'aide d'Excel-VBA)

Mise à jour de ce code. J'ai utilisé celui-ci pour changer toutes .les fichiers csv dans un dossier spécifié (étiqueté "Bron") et de les enregistrer au format 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

OriginalL'auteur Alex

Voici ma solution basée sur Excel VBA - exportation vers UTF-8, qui user3357963 lié à l'heure. Il comprend des macros pour l'exportation d'une gamme et un choix.

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

OriginalL'auteur Bryn