CODEWITHSUNDEEP
excelvbacharacter-encoding
JAT86
JAT86

Reputation: 1075

Write Excel range to UTF-8 text file

I have a range of cells that I am trying to save via macro as text file. The code below works, but I want it to save as UTF-8, since the some cells in the range contain the character enye (ñ):

Sub CreateTxtFiles()
Dim rng As Range
Dim ff As Long
Dim LastRow As Long
Dim i As Long
    LastRow = Range("AU" & Rows.Count).End(xlUp).Row
         
    Open "C:\Users\user1\Desktop\temp\output.txt" For Output As #ff
    
    For i = 2 To LastRow
        Set rng = Range("AU" & i)
        
        Print #ff, "" & rng.Value & ""
        
    Next i
    
    Close #ff
    
End Sub

I have seen this code in one of the solutions, but since I am a novice in VBA, I do not know how to integrate this code with my current code above:

Dim fsT As Object
Set fsT = CreateObject("ADODB.Stream")
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 And write binary data To the object
fsT.WriteText "special characters: äöüß"
fsT.SaveToFile sFileName, 2 'Save binary data To disk

How can I get the range to be exported as a UTF-8 text file?

Upvotes: 0

Views: 3170

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

Please, try the next way:

Sub CreateUTFTxtFile() 'it looks to return UTF-16 LE-BOM
 Dim rng As Range, LastRow As Long, i As Long
 Dim fso As Object, MyFile As Object, boolUnicode As Boolean
 Dim myFileName As String
 
    myFileName = "C:\Users\user1\Desktop\temp\output.txt"
    LastRow = Range("AU" & rows.count).End(xlUp).row
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    boolUnicode = True
    Set MyFile = fso.CreateTextFile(myFileName, False, boolUnicode) 'open the file to write Unicode:
       For i = 2 To LastRow
         MyFile.WriteLine (Range("AU" & i).Value)
       Next i
    MyFile.Close
End Sub

Edited:

Please, test the next code. It will create a real UTF-8 text file. And the code should be fast:

Private Sub CreateUTFT8tFile() 'UTF-8 BOM for huge files...
 Dim rng As Range, LastRow As Long, i As Long
 Dim fso As Object, MyFile As Object, boolUnicode As Boolean
 Dim myFileName As String, myFileName2 As String, strText As String
 
    myFileName = "C:\Users\user1\Desktop\temp\outputUTF16.txt" 'temporary text container
    myFileName2 = "C:\Users\user1\Desktop\temp\output.txt"
    LastRow = Range("AU" & rows.count).End(xlUp).row
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    boolUnicode = True
    If dir(myFileName) <> "" Then Kill myFileName
    Set MyFile = fso.CreateTextFile(myFileName, False, boolUnicode) 'open the file to write UTF-16:
       For i = 2 To LastRow
         MyFile.WriteLine (Range("AU" & i).Value)
       Next i
    MyFile.Close
    strText = readTextUTF16$(myFileName)   'read UTF-16 file, used as container for the case of huge text content

    With CreateObject("ADODB.Stream")
       .Charset = "utf-8": .Open
        .WriteText strText
        .SaveToFile myFileName2, 2          'convert to UTF-8 BOM
    End With
End Sub
Function readTextUTF16$(f)
    With CreateObject("ADODB.Stream")
        .Charset = "utf-16": .Open
        .LoadFromFile f
        readTextUTF16$ = .ReadText
    End With
End Function

If you do not like UTF-8 BOM, please use the next version:

Sub CreateUTF8TxtFilesNoBOM() 'UTF-8 no BOM
 Dim LastRow As Long, oStream As Object
 Dim myFileName As String, arrTxt, strTxt As String
 
    myFileName = "C:\Users\user1\Desktop\temp\output.txt"
    LastRow = Range("AU" & rows.count).End(xlUp).row
    arrTxt = Application.Transpose(Range("AU2:AU" & LastRow).Value)
    strTxt = Join(arrTxt, vbCrLf)
    
    WriteUTF8WithoutBOM strTxt, myFileName
End Sub
Function WriteUTF8WithoutBOM(strText As String, fileName As String)
  Dim UTFStream As Object, BinaryStream As Object
  With CreateObject("adodb.stream")
     .Type = 2: .Mode = 3: .Charset = "UTF-8"
     .LineSeparator = -1
     .Open: .WriteText strText, 1
     .Position = 3 'skip BOM' !!!
     Set BinaryStream = CreateObject("adodb.stream")
         BinaryStream.Type = 1
         BinaryStream.Mode = 3
         BinaryStream.Open
        'Strips BOM (first 3 bytes)
        .CopyTo BinaryStream
        .Flush
    .Close
  End With
    BinaryStream.SaveToFile fileName, 2
    BinaryStream.Flush
    BinaryStream.Close
End Function

Upvotes: 1

Related Questions