Макрос перекодировки (изменения кодировки) текста и файлов

Функции ChangeFileCharset и ChangeTextCharset предназначены для изменения кодировки символов в текстовых файлах и строках.

Исходную и конечную (желаемую) кодировку можно задать в параметрах вызова функций.

Список доступных на вашем компьютере кодировок можно найти в реестре Windows в ветке
HKEY_CLASSES_ROOT\MIME\Database\Charset

Среди доступных кодировок есть koi8-r, ascii, utf-7, utf-8, Windows-1250, Windows-1251, Windows-1252, и т.д. и т.п.

Определить исходную и конечную кодировку можно, воспользовавшись онлайн-декодером:
http://www.artlebedev.ru/tools/decoder/advanced/
(после преобразования снизу будет написано, из какой кодировки в какую переведён текст)

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

' Функция для перекодировки файла в UTF-8 без BOM (то же самое, что и UTF-8, только без первых 3 байтов)

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

Функция перекодировки текста в UTF-8 без BOM

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

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Это json_encode. Для этого нужен другой инструмент (функция):
https://excelvba.ru/code/JSON_decode

Указанный вами декодер вообще не распознаёт строку вида:
\u0410\u043a\u0442 \u043f\u043e \u0434\u0435\u043b\u0443 \u043e\u0431 \u0430\u0434\u043c\u0438\u043d\u0438\u0441\u0442\u0440\u0430\u0442\u0438\u0432\u043d\u043e\u043c \u043f\u0440\u0430\u0432\u043e\u043d\u0430\u0440\u0443\u0448\u0435\u043d\u0438\u0438 \u043e\u0442 22.04.2019 \u2116 18810145190422907616 \u0426\u0410\u0424\u0410\u041f \u0412 \u041e\u0414\u0414 \u0413\u0418\u0411\u0414\u0414 \u0423\u041c\u0412\u0414 \u0420\u041e\u0421\u0421\u0418\u0418 \u041f\u041e \u041a\u0423\u0420\u0413\u0410\u041d\u0421\u041a\u041e\u0419

Соответственно и функция не работает. Тут должно быть unicode в utf-8

Добрый день! Необходимо конвертировать текст из ASCII (отрезанный старший бит) в Windows-1251. Каким образом можно модифицировать макрос для решения задачи?

Надо выполнить замены для всех похожих букв по всему документу
У меня на сайте есть решения только для Excel. Для word готового нет (можем сделать под заказ, или поищите готовый макрос в интернете, - вы явно не первый, кто с такой проблемой столкнулся)

Добрый день.
Парни, есть такая проблема, сам я из Казахстана, юзер пишет текст в ворде, например слово "СЛОВО", где буква С была написана на англ.языке, а все остальное слово на русском, или есть такие слова где русский язык и казахский (с казахской клавиатуры). Теперь при проверке на плагиат выходит ошибка кодировки, программа не понимает таких слов из двух или более языков, посоветуйте пожалуйста выход из такой ситуации, слышал что можно с помощью макросов, вот только с макросами не дружу, но в целом с понятия имею...

Спасибо!

Ребята, спасибо вам огромное !
Это просто вечные ценности !
Удачи вам.

Огромное СПАСИБО за такой функционал!
Полдня истратил, пока нашел, как же из Excel перевести данные в UTF-8.
И тут такой подарок!
Это просто супер!

Здравствуйте, подскажите как пересохранить xls файл в формат csv с кодировкой utf8 без BOM разделитель ; с именем исходного файла

Алексей, ну есть же в конце статьи отдельная функция для вашего случая...
Вызывается так:

ChangeFileCharset_UTF8noBOM filename

Скажите пожалуйста,
хотелось бы на выходе получить файл в кодировке UTF-8 без BOM
вызываю так: ChangeFileCharset filename, "UTF-8", "Windows-1251"
все нормально, но файл получается UTF-8
а хотелось бы UTF-8 без BOM
Это возможно? Если да, то как указать во втором параметре вызова функции?

Здравствуйте, Павел
В общем случае, кодировку txt файла никак не угадать (не проверить)
Можно лишь попробовать угадать, анализируя первые байты текста (правда, верно угадать можно с вероятностью, очень близкой к 100%)

Изменить кодировку без перезаписи файла — никак.
Смена кодировки текстового файла — это изменение байтового представления этого текста
(после перекодировки, файл может увеличиться или уменьшаться в размере в 2 раза)

Готовый макрос предложить не могу (ни разу подобное не делал, и кода немало получится)

Варианты решения проблемы:
1) ручная обработка, при помощи текстового редактора Notepad++
В нём можно открыть сразу кучу файлов, а потом, переключаясь между ними, смотреть текущую кодировку, и, при необходимости, перекодировать одним нажатием кнопки (см. меню Кодировки в Notepad++)

2) макрос под заказ. высылаете несколько файлов для примера, указываете, где кодировка верная, а где надо исправить, - я посмотрю, что можно сделать (если там не несколько разных кодировок, - макрос по цене обойдется около 2 т.р.)

А как 1) просто проверить кодировку текстового файла и вывести результат?
и 2) изменить ее без перезаписи всего текста?
Имеется в виду не кодировка текста, а та кодировка, которой файл помечен (для UTF-8, в частности, это два специфических сигнальных байта в начале файла, которые не отображаются как текст).
Нужно вот для чего. Обнаружилось, что если NC-файл (фактически это просто текстовый файл) для ЧПУ сохранен в кодировке, отличной от ANSI, то это вызывает зависание машины, в каком-то подлом проценте случаев. Теперь надо все файлы перепроверить и починить. А их тысячи.
Если при пересохранении в ANSI будут потеряны какие-то буквы - не страшно. Эти неанглийские буквы попадаются там только в комментариях к коду. Никто не знал о такой засаде и писали как попало.

У меня почему-то при кодировании анси в уникод, не прокатил параметр "utf-8", а получилось только с "Unicode".

Вы Гений! Большое-пребольшое спасибо!!!!!!

1) для сохранения текста в нужной кодировке, используйте эту функцию:
http://excelvba.ru/code/SaveTextToFile

2) «пишет в него все одну строчку» — в файл пишется то, что находится в переменной.
Вы используете построчную запись в файл, моя же функция просто создает файл единоразово

Вот как надо было написать:

Sub test()
    Dim TextOut$
 
    For i = 1 To 10
        ' накапливаем текст в переменной TextOut$,
        ' после каждого значения добавляя перевод строки vbNewLine
        TextOut$ = TextOut$ & "document.write('" & Cells(i, 1).Value & "')" & vbNewLine
    Next i
 
    ' сохраняем результат в файл
    SaveTextToFile TextOut$, "c:\test.txt", "utf-8"
End Sub

Дело в том, что в результате у меня должен выйти файл в кодировке utf-8 с 8 строчками, типа
"file.js"
строка 1
Строка 2
...
Строка 8

Вот никак и не выходит у меня "каменный цветок"... SaveTXTfile файл создает и пишет в него одну строчку, AddIntoTXTfile файл создает и пишет в него все одну строчку - и все в не в utf-8.

Подскажите пожалуйста, если не затруднит, что я недопонимаю? :-(

Вадим, так всё проще делается, без всяких перекодировок.
Формируете нужный текст в переменной TextOut,
а потом записываете его в файл функцией SaveTXTfile:
http://excelvba.ru/code/txt

А если в файл не записываете, - зачем вообще кодировку менять???

Здравствуйте! Ну так я эту строку закомментировал ;-) потому что неперекодирует... из ansi в utf-8, а вот функция сохранения в файл отработала отлично... Но мне нужно именно текст...
Function ChangeTextCharset(ByVal txt$, ByVal DestCharset$, _
Optional ByVal SourceCharset$) As String

' 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

'Кусок текста моего макроса

t0 = "document.write('"
t = "document.write('"
t1 = ""
t2 = "')"
t3 = "')"

Open fOut For Output As 1
For i = j - 1 To j - 8 Step -1
Tttt = Cells(i, 1).Value
TextOut = t0 + Tttt + t3
TextOutFull = ChangeTextCharset(TextOut, "utf-8", "ansi")
Print #1, TextOutFull
Close #1

Здравствуйте, Вадим.
Ошибка в этой функции вылетать не может, - т.к. в начале кода написано On Error Resume Next
Проблема, возможно, из-за неправильно заданных кодировок (исходная или конечная)

Здравствуйте! Почему-то при использовании функции ChangeTextCharset вылетает ошибка в строке ChangeTextCharset = .ReadText - Параметр задан не верно

Под Mac много чего не работает из макросов.
Увы, подсказать решение не могу, - я пишу макросы только под Windows, и не знаю возможности макросов в Mac.

Одна проблема - adodb не работает на mac. Не подскажете, как поменять функцию ChangeTextCharset для работы под Mac?

1) Функцией ChangeFileCharset не могу воспользоваться, потому что получается, что она вызывается из того же файла, который я пытаюсь перекодировать.
2) Исходную кодировку я не указываю, т.к. она опциональна. Но попробовала указать - не помогло.
Опять же, если бы вопрос был в неверном применении функции, у меня бы в любую кодировку не получалось перекодировать, но у меня не срабатывает только utf-8, в любую другую - без проблем!

Здравствуйте, Арина.
с чем связано, - не знаю, надо код смотреть.
Скорее всего, с неправильным указанием исходной кодировки,
или ошибкой в использовании функции.

Попробуйте функцию перекодировки всего файла сразу, - оно правильнее, чем построчно перекодировать...

Добрый день!
Спасибо за функции!
Пытаюсь воспользоваться ChangeTextCharset, чтобы перекодировать строки в файле в UTF-8, но при попытке сделать это получаю как результат только первый символ из строки, остальные просто обрезаются.
Пробовала перекодировать той же функцией в UTF-16, ничего не обрезается, все сохраняется верно.
С чем это может быть связано?

А ваш файл в каком формате?

Если файл можно открыть блокнотом (расширение CSV, TXT или даже некоторые XLS), - то сначала перекодируйте файл, и только потом его открывайте.

Если же файл сохранён в одном из форматов Excel, - то можно преобразовать диапазон в текстовую строку, перекодировать текст, а затем преобразовать текст в массив, и записать обратно на лист.

На пример, открыл книгу, на листе имеется список, он не читабелен, как его перекодировать? Только с помощью цикла?

Нет, только текстовую строку, или файл
А зачем это вообще надо?
Преобразуйте массив в текстовую строку, перекодируйте, - а затем обратно преобразуйте в массив.

Возможно ли с помощь этих функций перекодировать масив?
Типа так
arr = ChangeTextCharset(Rarr, "UTF-8", "Windows-1251")

Спасибо!
Спустя кучу времени эта статья была актуальна, для меня :)
Правда сначала не работало, потому что я использовал исходную кодировку "ANSI" (эту кодировку(?) скрипт не узнал), а оказалось надо было писать "Windows-1251".

Спасибо! Всё работает!
ChangeTextCharset - это то, что надо!

Для корректной копипасы кирилицы в редакторе VBA (в частности в MS Excel 2003) необходимо перед копипастой установить язык Ru для окна редактора VBA (в языковой панели).

Антон, даже не знаю... я много раз пользовался этой функцией в разных проектах, - и все нормально работало.

Просто я не знаю, есть ли какие ограничения и особенности этой функции (может, у вас файл огромный, а тут есть ограничение на его длину, или кодировку надо задавать в нижнем регистре (я, например, указывал всегда windows-1251 и utf-8), может, ещё что-то...)

Проверьте на другом файле, - по идее, все должно корректно работать.
Что попадает в переменную Total после выполнения макроса?

Добрый день!
делаю вызов Вашей функции перекодировки текстового файла из процедуры (файл в формате ANSI, перекодирую в UTF-8)
В результате перекодировки получается, что в конечном файле нет ни одной русской буквы - они просто удалены.
Подскажите пожалуйста в чем может быть причина?
Благодарю!

Sub dfle()
filename = "d:\file.txt"
DestCharset = "Windows-1251"
SourceCharset = "UTF-8"
Total = ChangeFileCharset(filename, DestCharset, SourceCharset)
End Sub

Еще решение:

Sub Create_UTF8_csv_file()
  csvFileName = "d:\Data.csv"
 
  Dim ADOStream
  Set ADOStream = CreateObject("ADODB.Stream")
  With ADOStream
    .Open
    .Position = 0
    .Charset = "utf-8"
    .WriteText "Categories , Pears, Oranges, Bananas" & Chr(10) + Chr(13) + "John, 8, 4, 6, 5" & Chr(10) + Chr(13) + "Jane , 3, 4, 2, 3" & Chr(10) + Chr(13) + "Joe , 86, 76, 79, 77" & Chr(10) + Chr(13) + "Janet , 3, 16, 13, 15"
    .SaveToFile csvFileName, 2 ' overwrite if exists
    .Close
  End With
  Set ADOStream = Nothing
End Sub

Добрый день!
Спасибо за функции, очень помогло.
Не подскажите где можно почитать подробней про Adodb.Stream?в браузерах по запросу выдаются ссылки на форумы с уже конкретными проблемами, хотелось бы изучить методы и принцип работы этой библиотеки.

Сергей, увы, ничего подсказать не могу.
Я на всех своих компах устанавливал только «русскую» Windows, и ни разу не было проблем с использованием кириллицы в коде.

Одно но: при копировании кода из редактора VBA, могут копироваться кракозябры. Но это лечится приведенным вами файлом реестра.

И ещё - ваша проблема мне не совсем понятна.
Одно дело - если не получается использовать русскоязычные названия для переменных (проблема в отсутствии русского языка в Windows),
и совсем другое - если ваш макрос с веб-страницы получает текст в неверной кодировке (тут уже проблема в макросе)

Здравствуйте!
Я заметил, что Вы используете в написании кода кирилицу. Когда я пытаюсь делать то же самое, или считывать информацию с веб страницу на русском языке, то получаю в лучшем случае абрукадабру (Ïðåâûøåí), а в худшем "?".

У меня стоит английская версия Win 7 и Office 2010 c поддержкой русского языка. Перерыл интернет и нашел только файл реестра со следующим кодом:

REGEDIT4

[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\CodePage]
"1250"="c_1251.nls"
"1251"="c_1251.nls"
"1252"="c_1251.nls"
"1253"="c_1251.nls"
"1254"="c_1251.nls"
"1255"="c_1251.nls"
"437"="c_437.nls"
"866"="c_866.nls"
"ACP"="1251"
"OEMCP"="866"
"MACCP"="10007"
"OEMHAL"="vga866.fon"

После исполнения стала появлятся абракадабра вместо ?. Не подскажете, что нужно сделать, чтобы VBA поддерживал кирилицу как следует?

С уважением,
Сергей.

Я думала, это и есть форум по экселю (сюда попала по ссылке из форума по экселю).
Хочу бесплатно: файл не один, их будет много, и я сама - рабочий, а не заказчик, еще неизвестно, заплатят ли мне за эту работу ))).
Спасибо за ответ.

Nata, это возможно.
Писать код, в надежде, что вы разберетесь в нем, не буду.
К тому же, встроить код в XLSX не получится - надо преобразовать файл в XLSB (иди вынести код в надстройку)

Если готовы оплатить помощь - оформляйте заказ, прикрепляйте свой файл, - я встрою в него код.
Если хотите бесплатно - обращайтесь за помощью на форумы по Excel, там вам все разъяснят и покажут.

Добрый день! Помогите, пожалуйста, в таком вопросе: есть экселевский (2007) файл .xlsx, который нужно перекодировать в .csv UTF-8 с тем, чтобы потом заливать на сайт (требования разработчиков сайта). Если я правильно поняла, для этой цели можно использовать второй макрос, проблема в том, что я эксель только-только осваиваю, не то что VBA. И, если с первым макросом у меня получилось слово "вопрос", то со вторым - я даже не знаю, получилось или нет. Предполагаю, что мало просто скопировать все в VBA, а нужно указать имя исходного файла (и, возможно, путь к нему), так же и конечного.
Кто разбирается, опишите, пожалуйста, популярно, как все это сделать (допустим, мой исходный файл "Инфа.xlsx" живет на D:\ТОВАРЫ\
как с помощью второго макроса превратить его в Инфа.csv (если это вообще возможно).

Попробуйте закомментировать строку On Error Resume Next в моей функции.

Если при этом макрос остановится с ошибкой - вы сразу обнаружите её причину, посмотрев значение передаваемой функции переменной.

PS: У меня совершенно нет опыта работы с Access - так что, возможно, причина и в вашем коде.

Для тестирования я бы заменил строку ns = ChangeTextCharset(ss, "UTF-8", "Windows-1251")

следующим кодом:

debug.print "Before: ", ss
ns = ChangeTextCharset(ss, "UTF-8", "Windows-1251")
debug.print "After: ", ns

Потом в окне Immediate изучить результат - и всё станет понятно.

Спасибо! Работает хорошо.
Но умення вопрос...
В цикле Do ... Loop назначает новую кодировку на первою строку, а все остальные остаются в исходной кодировке. Пример:

Dim ss As String
     Dim ns As String
     Dim st As ADODB.Recordset
     Set st = New ADODB.Recordset
        With st
            .Open "NoteWE", CurrentProject.Connection, adOpenStatic, adLockPessimistic
            .MoveFirst
        End With
     Dim nt As ADODB.Recordset
     Set nt = New ADODB.Recordset
        With nt
            .Open "Клев", CurrentProject.Connection, adOpenStatic, adLockPessimistic
 
        End With
     ' вызываем функцию ChangeTextCharset с указанием кодировок
    Do Until st.EOF
        ss = st(0).Value
        ns = ChangeTextCharset(ss, "UTF-8", "Windows-1251")
        nt.AddNew
        nt.Fields(1) = ns
        nt.Update
        st.MoveNext
    Loop

В чем я ошибся?
Зарание спасибо

Круто!!!
Спасибо, вчера весь день искал... ничего не помогло...
Только эта статья помогла...

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
           ___            __          __ 
__ _ / _ \ ___ / _| ___ / _|
/ _` | | (_) | / _ \ | |_ / __| | |_
| (_| | \__, | | __/ | _| \__ \ | _|
\__, | /_/ \___| |_| |___/ |_|
|___/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.