How to export sheet/column in VBA to XML in UTF-8 formatting

Question

I have written a macro that outputs xml-lines (with the right formatting) in column A of a certain sheet. So each row in that sheet should correspond to 1 line in an xml-file. If I copy-paste this column in notepad en save it as.xml (after removing the "-tags that are automatically placed before and after each line), I have the file that I need. The macro should generate several files so it is not pratically to do this manually for each file.

I have found following code to do the save-job:

strFileName = Application.ActiveWorkbook.Path & "\" & NameOfTheFile & ".xml"
Sheets(NameOfSheetContainingData).SaveAs Filename:=strFileName, FileFormat:=xlTextPrinter, CreateBackup:=False

This works perfectly, except for the UTF-8 formatting. Where I have a 'é' in excel, it turns in an 'xE9' in the xml-file.

I would be extreemly greatful I somebody could help me with this problem:)

Answer 1

Try

Sub SaveUTF8()

   Const NameOfTheFile = "test"
   
   Dim FSO, ts, ar, strFilename As String, s As String
   Dim i As Long, t0 As Single: t0 = Timer

   strFilename = ActiveWorkbook.Path & "\" & NameOfTheFile & ".xml"

   Set FSO = CreateObject("Scripting.FileSystemObject")
   Set ts = FSO.createTextfile(strFilename, 1, 1) ' oversrite, utf8
 
   ar = Sheets(1).UsedRange.Columns(1).Value2 'NameofSheetContainingData

   For i = LBound(ar) To UBound(ar)
       s = s & ar(i, 1) & vbCrLf
       If i Mod 1000 = 0 Then
           ts.write s
           s = ""
       End If
   Next
   ts.write s
   ts.Close
   MsgBox strFilename & " created in " & Int(Timer - t0) & " seconds"
   
End Sub

Alternative

Sub SaveUTF8_2()

    Const NameOfTheFile = "test"
   
    Dim strFilename As String, cell As Range
    Dim t0 As Single: t0 = Timer

    strFilename = ActiveWorkbook.Path & "\" & NameOfTheFile & ".xml"

    Dim objStream
    Set objStream = CreateObject("ADODB.Stream")
    With objStream
        .Type = 2 'adTypeText
        .Open
        .Charset = "UTF-8"
        For Each cell In Sheets(1).UsedRange.Columns(1).Cells
            .writetext cell.Value2, 1 'adWriteLine
        Next
        .Position = 0
        .SaveToFile strFilename, 2  'adSaveCreateOverWrit
    End With
    objStream.Close
    MsgBox strFilename & " created in " & Int(Timer - t0) & " seconds"

End Sub

Sub testdata()
    Sheet1.Range("A1:A300000").Value2 = _
    "<tag atr1=""attribute one"" atr2=""attribute two"">some text here ééé</tag>"
End Sub

update - batch write 1000 lines

update2 - added alternative