Сохранить файл в utf 8 vba excel

Sub ПримерИспользования_ChangeTextCharset()
 
    ИсходнаяСтрока = "бНОПНЯ"
    ' вызываем функцию ChangeTextCharset с указанием кодировок
    ' (меняем кодировку с KOI8-R на Windows-1251)
    ПерекодированнаяСтрока = ChangeTextCharset(ИсходнаяСтрока, "Windows-1251", "KOI8-R")
 
    MsgBox "Результат перекодировки: """ & ПерекодированнаяСтрока & """", _
           vbInformation, "Исходная строка: """ & ИсходнаяСтрока & """"
 
End Sub

Function ChangeFileCharset(ByVal filename$, ByVal DestCharset$, _
                           Optional ByVal SourceCharset$) As Boolean
    ' функция перекодировки (смены кодировки) текстового файла
    ' В качестве параметров функция получает путь filename$ к текстовому файлу,
    ' и название кодировки DestCharset$ (в которую будет переведён файл)
    ' Функция возвращает TRUE, если перекодировка прошла успешно
    On Error Resume Next: Err.Clear
    With CreateObject("ADODB.Stream")
        .Type = 2
        If Len(SourceCharset$) Then .Charset = SourceCharset$    ' указываем исходную кодировку
        .Open
        .LoadFromFile filename$    ' загружаем данные из файла
        FileContent$ = .ReadText   ' считываем текст файла в переменную FileContent$
        .Close
        .Charset = DestCharset$    ' назначаем новую кодировку
        .Open
        .WriteText FileContent$
        .SaveToFile filename$, 2   ' сохраняем файл уже в новой кодировке
        .Close
    End With
    ChangeFileCharset = Err = 0
End Function

Function ChangeTextCharset(ByVal txt$, ByVal DestCharset$, _
                           Optional ByVal SourceCharset$) As String
    ' функция перекодировки (смены кодировки) текстовоq строки
    ' В качестве параметров функция получает текстовую строку txt$,
    ' и название кодировки DestCharset$ (в которую будет переведён текст)
    ' Функция возвращает текст в новой кодировке
    On Error Resume Next: Err.Clear
    With CreateObject("ADODB.Stream")
        .Type = 2: .Mode = 3
        If Len(SourceCharset$) Then .Charset = SourceCharset$    ' указываем исходную кодировку
        .Open
        .WriteText txt$
        .Position = 0
        .Charset = DestCharset$    ' назначаем новую кодировку
        ChangeTextCharset = .ReadText
        .Close
    End With
End Function

Function ChangeFileCharset_UTF8noBOM(ByVal filename$, Optional ByVal SourceCharset$) As Boolean
    ' функция перекодировки (смены кодировки) текстового файла
    ' В качестве параметров функция получает путь filename$ к текстовому файлу,
    ' Функция возвращает TRUE, если перекодировка прошла успешно
    On Error Resume Next: Err.Clear
    DestCharset$ = "utf-8"
    With CreateObject("ADODB.Stream")
        .Type = 2
        If Len(SourceCharset$) Then .Charset = SourceCharset$        ' указываем исходную кодировку
        .Open
        .LoadFromFile filename$        ' загружаем данные из файла
        FileContent$ = .ReadText        ' считываем текст файла в переменную FileContent$
        .Close
        .Charset = DestCharset$        ' назначаем новую кодировку "utf-8"
        .Open
        .WriteText FileContent$
 
        'Write your data into the stream.

        Dim binaryStream As Object
        Set binaryStream = CreateObject("ADODB.Stream")
        binaryStream.Type = 1
        binaryStream.Mode = 3
        binaryStream.Open
        'Skip BOM bytes
        .Position = 3
        .CopyTo binaryStream
        .Flush
        .Close
        binaryStream.SaveToFile filename$, 2
        binaryStream.Close
    End With
    ChangeFileCharset_UTF8noBOM = Err = 0
End Function

Function EncodeUTF8noBOM(ByVal txt As String) As String
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        Select Case AscW(l)
            Case Is > 4095: t = Chr(AscW(l)  64  64 + 224) & Chr(AscW(l)  64) & Chr(8 * 16 + AscW(l) Mod 64)
            Case Is > 127: t = Chr(AscW(l)  64 + 192) & Chr(8 * 16 + AscW(l) Mod 64)
            Case Else: t = l
        End Select
        EncodeUTF8noBOM = EncodeUTF8noBOM & t
    Next
End Function

See my answer for the solution.

asked Apr 6, 2015 at 8:50

So I came in the situation where I needed this code again, and I read the comments and Leonard’s answer, which made me update my code together with better descriptions.

This code will convert your Excel sheet and save it as a CSV file with the UTF-8 without BOM encoding. I found this code on a website, so I will not take credit for it. CSV without BOM link

Option Explicit

Sub CSVFileAsUTF8WithoutBOM()
Dim SrcRange As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim FName As Variant
Dim UTFStream As Object
Dim BinaryStream As Object

' ADO Constants
Const adTypeBinary = 1 ' The stream contains binary data
Const adTypeText = 2 ' The stream contains text data (default)
Const adWriteLine = 1 ' write text string and a line separator (as defined by the LineSeparator property) to the stream.
Const adModeReadWrite = 3 ' Read/write
Const adLF = 10 ' Line feed only - default is carriage return line feed (adCRLF)
Const adSaveCreateOverWrite = 2 ' Overwrites the file with the data from the currently open Stream object, if the file already exists

' Open this workbook location
ChDrive Left(ThisWorkbook.Path, 1)
ChDir ThisWorkbook.Path

' ask for file name and path
  FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")

' prepare UTF-8 stream
  Set UTFStream = CreateObject("adodb.stream")
  UTFStream.Type = adTypeText
  UTFStream.Mode = adModeReadWrite
  UTFStream.Charset = "UTF-8"
  UTFStream.LineSeparator = adLF
  UTFStream.Open

  'set field separator
  ListSep = ";"
  'set source range with data for csv file
  If Selection.Cells.Count > 1 Then
    Set SrcRange = Selection
  Else
    Set SrcRange = ActiveSheet.UsedRange
  End If

  For Each CurrRow In SrcRange.Rows
    'enclose each value with quotation marks and escape quotation marks in values
    CurrTextStr = ""
    For Each CurrCell In CurrRow.Cells
      CurrTextStr = CurrTextStr & """" & Replace(CurrCell.Value, """", """""") & """" & ListSep
    Next
    'remove ListSep after the last value in line
    While Right(CurrTextStr, 1) = ListSep
      CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
    Wend
    'add line to UTFStream
    UTFStream.WriteText CurrTextStr, adWriteLine ' Writes character data to a text Stream object
  Next

  'skip BOM
  UTFStream.Position = 3 ' sets or returns a long value that indicates the current position (in bytes) from the beginning of a Stream object

  'copy UTFStream to BinaryStream
  Set BinaryStream = CreateObject("adodb.stream")
  BinaryStream.Type = adTypeBinary
  BinaryStream.Mode = adModeReadWrite
  BinaryStream.Open ' Opens a Stream object

  'Strips BOM (first 3 bytes)
  UTFStream.CopyTo BinaryStream ' Copies a specified number of characters/bytes from one Stream object into another Stream object

  UTFStream.Flush ' Sends the contents of the Stream buffer to the associated underlying object
  UTFStream.Close ' Closes a Stream object

  'save to file
  BinaryStream.SaveToFile FName, adSaveCreateOverWrite
  BinaryStream.Flush ' Sends the contents of the Stream buffer to the associated underlying object
  BinaryStream.Close ' Closes a Stream object

End Sub

answered Apr 2, 2020 at 21:43